Lotto triplets,quads and more

hello pls vba code for this file example extract triples: 1,4,6 OR 2,9,48

and i must 4-6digitcode to extract examle 1,4,6,12 1,4,6,12,15 1,4,6,12,15,18 PLS

https://www.dropbox.com/s/0ksum9oewkxuw7o/200test.xlsx

this macro is for triples

Sub blah()
Set d = CreateObject("Scripting.dictionary")
Set cll = Range("A1")
Dim X()
Do
    xx = Split(Application.Trim(cll.Value))
    Debug.Assert UBound(xx) = 5
    If UBound(xx) = 5 Then
        For I = 0 To 3
            For j = I + 1 To 4
                For k = j + 1 To 5
                    Smaller = Application.Min(xx(I), xx(j), xx(k))
                    Larger = Application.Max(xx(I), xx(j), xx(k))
                    Middle = Application.Median(xx(I), xx(j), xx(k))
                    thisTriplet = Format(Smaller, "00") & "," &  Format(Middle, "00") & "," & Format(Larger, "00")
                    If d.Exists(thisTriplet) Then
                        d.Item(thisTriplet) = d.Item(thisTriplet) + 1
                    Else
                        d.Add thisTriplet, 1
                    End If
                Next k
            Next j
        Next I
    End If
    Set cll = cll.Offset(1)
Loop Until IsEmpty(cll)
ReDim X(1 To d.Count, 1 To 2)
I = 0
For Each p In d.Keys
    I = I + 1
    X(I, 1) = p
    X(I, 2) = d.Item(p)
Next p
Set rngResults = Range("C2").Resize(d.Count, 2)
rngResults.Value = X
With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=rngResults.Columns(2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SortFields.Add Key:=rngResults.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange rngResults
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

Hi dragon66,

Invest ;-) some time to read http://www.excelforum.com/forum-rule...rum-rules.html

During reading focus on code tags and on attachments. Also do not SHOUT http://netiquette.wikia.com/wiki/Rul...t_use_all_caps

So please, edit your post. I insist.

As for the macro - not tested and edited it only - try this:

Sub blah4()
Set d = CreateObject("Scripting.dictionary")
Set cll = Range("A1")
Dim X()
Do
xx = Split(Application.Trim(cll.Value), " ")
If UBound(xx) = 5 Then
For I = 0 To 2
For j = I + 1 To 3
For k = j + 1 To 4
For l = k + 1 To 5
foursome = Format(xx(I), "00") & "," & Format(xx(j), "00") & "," & Format(xx(k), "00") & "," & Format(xx(l), "00")
Smaller = Application.Min(xx(I), xx(j), xx(k), xx(l))
Larger = Application.Max(xx(I), xx(j), xx(k), xx(l))
'for the 5some also median ;-)
foursome = Replace(Replace(Replace(Replace("," & foursome & ",", Format(Smaller, "00"), ""), Format(Larger, "00"), ""), ",,", ","), ",,", ",")
inner = Split(Mid(foursome, 2, Len(foursome) - 2), ",")
Firstmiddle = Application.Min(inner(0), inner(1))
Secondmiddle = Application.Max(inner(0), inner(1))
thisfoursome = Format(Smaller, "00") & "," & Format(Firstmiddle, "00") & "," & Format(Secondmiddle, "00") & "," & Format(Larger, "00")
If d.Exists(thisfoursome) Then
d.Item(thisfoursome) = d.Item(thisfoursome) + 1
Else
d.Add thisfoursome, 1
End If
Next l
Next k
Next j
Next I
End If
Set cll = cll.Offset(1)
Loop Until IsEmpty(cll)
ReDim X(1 To d.Count, 1 To 2)
I = 0
For Each p In d.Keys
I = I + 1
X(I, 1) = p
X(I, 2) = d.Item(p)
Next p
Set rngResults = Range("C2").Resize(d.Count, 2)
rngResults.Value = X
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rngResults.Columns(2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=rngResults.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngResults
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

hi kaper and 5,6 digit combination single script? pls this sub blah4 script is perfectly nice

and Sub blah5()
Set d = CreateObject("Scripting.dictionary")
Set cll = Range("A1")
Dim X()
Do

Sub blah6()
Set d = CreateObject("Scripting.dictionary")
Set cll = Range("A1")
Dim X()
Do

Follow the rules: http://www.excelforum.com/forum-rule...rum-rules.html

Edit your post. Now 2 posts.

I nic więcej nie napiszę, dopóki nie poprawisz!

for 5s:
as I already wrote, just add i loop and again use median:

Sub blah5()
Set d = CreateObject("Scripting.dictionary")
Set cll = Range("A1")
Dim X()
Do
xx = Split(Application.Trim(cll.Value), " ")
If UBound(xx) = 5 Then
For I = 0 To 1
For j = I + 1 To 2
For k = j + 1 To 3
For l = k + 1 To 4
For m = l + 1 To 5
fivesome = Format(xx(I), "00") & "," & Format(xx(j), "00") & "," & Format(xx(k), "00") & "," & Format(xx(l), "00") & "," & Format(xx(m), "00")
Smaller = Application.Min(xx(I), xx(j), xx(k), xx(l), xx(m))
Middle = Application.Median(xx(I), xx(j), xx(k), xx(l), xx(m))
Larger = Application.Max(xx(I), xx(j), xx(k), xx(l), xx(m))
fivesome = Replace(Replace(Replace(Replace(Replace("," & fivesome & ",", Format(Smaller, "00"), ""), Format(Larger, "00"), ""), Format(Middle, "00"), ""), ",,", ","), ",,", ",")
inner = Split(Mid(fivesome, 2, Len(fivesome) - 2), ",")
Firstmiddle = Application.Min(inner(0), inner(1))
Secondmiddle = Application.Max(inner(0), inner(1))
thisfivesome = Format(Smaller, "00") & "," & Format(Firstmiddle, "00") & "," & Format(Middle, "00") & "," & Format(Secondmiddle, "00") & "," & Format(Larger, "00")
If d.Exists(thisfivesome) Then
d.Item(thisfivesome) = d.Item(thisfivesome) + 1
Else
d.Add thisfivesome, 1
End If
Next m
Next l
Next k
Next j
Next I
End If
Set cll = cll.Offset(1)
Loop Until IsEmpty(cll)
ReDim X(1 To d.Count, 1 To 2)
I = 0
For Each p In d.Keys
I = I + 1
X(I, 1) = p
X(I, 2) = d.Item(p)
Next p
Set rngResults = Range("C2").Resize(d.Count, 2)
rngResults.Value = X
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rngResults.Columns(2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=rngResults.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngResults
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

For 6 - note that you don't have to use loops at all - you are just checking if all are repeated. and moreover - they are already sorted so code is shorter again.
Please note how indenting improves readability of the code

Sub blah6()
Set d = CreateObject("Scripting.dictionary")
Set cll = Range("A1")
Dim X()
Do
  xx = Split(Application.Trim(cll.Value), " ")
  If UBound(xx) = 5 Then
    sixsome = ""
    For i = 0 To 5
      sixsome = sixsome & "," & Format(xx(i), "00")
    Next i
    sixsome = Mid(sixsome, 2)
    If d.Exists(sixsome) Then
      d.Item(sixsome) = d.Item(sixsome) + 1
    Else
      d.Add sixsome, 1
    End If
  End If
  Set cll = cll.Offset(1)
Loop Until IsEmpty(cll)
ReDim X(1 To d.Count, 1 To 2)
i = 0
For Each p In d.Keys
  i = i + 1
  X(i, 1) = p
  X(i, 2) = d.Item(p)
Next p
Set rngResults = Range("C2").Resize(d.Count, 2)
rngResults.Value = X
With ActiveSheet.Sort
  .SortFields.Clear
  .SortFields.Add Key:=rngResults.Columns(2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  .SortFields.Add Key:=rngResults.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .SetRange rngResults
  .Header = xlNo
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
End With
End Sub

and sub7 for this file? https://www.dropbox.com/s/idepug3hfwzgg37/7new.xlsx This is really the last:p perfect!!! thx you very much