Post a reply to find 10 matching numbers out of 20 vba good for keno
Sub combo10()
On Error Resume Next
Dim a%, b%, c%, d%, e%, f%, g%, h%, i%, j%, m%, n&, p&, dc As Object, r, T()
Set dc = CreateObject("Scripting.Dictionary")
'Collection combinations
With ActiveSheet
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For p = 1 To n
For a = 2 To 12
For b = a + 1 To 13
For c = b + 1 To 14
For d = c + 1 To 15
For e = d + 1 To 16
For f = e + 1 To 17
For g = f + 1 To 18
For h = g + 1 To 19
For i = h + 1 To 20
For j = i + 1 To 21
r = .Cells(p, a) & "|" & .Cells(p, b) & "|" & .Cells(p, c) & "|" _
& .Cells(p, d) & "|" & .Cells(p, e) & "|" & .Cells(p, f) & "|" & .Cells(p, g) & "|" & .Cells(p, h) & "|" & .Cells(p, i) & "|" & .Cells(p, j)
If dc.exists(r) Then
m = CInt(dc(r)) + 1: dc(r) = m
Else
dc(r) = 1
End If
Next j
Next i
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
Next p
End With
'
For p = 2 To n - 1
For Each r In dc.keys
If CInt(dc(r)) < p Then dc.Remove (r)
Next r
If dc.Count < 1000 Then Exit For
Next p
'Array
ReDim T(dc.Count, 10): n = 0
For Each r In dc.keys
n = n + 1
T(n, 10) = CInt(dc(r))
For p = 0 To 9
T(n, p) = Split(r, "|")(p)
Next p
Next r
dc.RemoveAll
T(0, 0) = "combinations of 10": T(0, 10) = "Hits"
'Assignment and formatting, sorting
Application.ScreenUpdating = False
With Worksheets.Add(after:=Worksheets(ActiveSheet.Name))
With .Range("A1").Resize(n + 1, 11)
.Value = T
.Columns("A:j").ColumnWidth = 5
.Columns("k").ColumnWidth = 10
.HorizontalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Range("A1:j1").Merge
End With
With .Range("A2").Resize(n, 11)
.Sort key1:=.Cells(1, 8), order1:=xlAscending, key2:=.Cells(1, 9), order2:=xlAscending, _
key3:=.Cells(1, 10), order3:=xlAscending, Header:=xlNo
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), order2:=xlAscending, _
key3:=.Cells(1, 3), order3:=xlAscending, Header:=xlNo
.Sort key1:=.Cells(1, 7), order1:=xlDescending, Header:=xlNo
.Sort key1:=.Cells(1, 8), order1:=xlDescending, Header:=xlNo
.Sort key1:=.Cells(1, 9), order1:=xlDescending, Header:=xlNo
.Sort key1:=.Cells(1, 10), order1:=xlDescending, Header:=xlNo
.Sort key1:=.Cells(1, 11), order1:=xlDescending, Header:=xlNo
End With
End With
End Sub