this is for 4 out 20 for FUADFF
Sub CombiMax4()
On Error Resume Next
Dim a%, b%, c%, d%, m%, n&, i&, dc As Object, k, T()
Set dc = CreateObject("Scripting.Dictionary")
'Recueil combinaisons
With ActiveSheet
n = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To n
For a = 2 To 18
For b = a + 1 To 19
For c = b + 1 To 20
For d = c + 1 To 21
k = .Cells(i, a) & "|" & .Cells(i, b) & "|" & .Cells(i, c) & "|" _
& .Cells(i, d)
If dc.exists(k) Then
m = CInt(dc(k)) + 1: dc(k) = m
Else
dc(k) = 1
End If
Next d
Next c
Next b
Next a
Next i
End With
'Epuration combi < à nb lignes -1
For i = 2 To n - 1
For Each k In dc.keys
If CInt(dc(k)) < i Then dc.Remove (k)
Next k
If dc.Count < 1000 Then Exit For
Next i
'Mise en tableau
ReDim T(dc.Count, 4): n = 0
For Each k In dc.keys
n = n + 1
T(n, 4) = CInt(dc(k))
For i = 0 To 3
T(n, i) = Split(k, "|")(i)
Next i
Next k
dc.RemoveAll
T(0, 0) = "combinations of 4": T(0, 4) = "Hits"
'Affectation et mise en forme, tri
Application.ScreenUpdating = False
With Worksheets.Add(after:=Worksheets(ActiveSheet.Name))
With .Range("A1").Resize(n + 1, 5)
.Value = T
.Columns("A:D").ColumnWidth = 5
.Columns("E").ColumnWidth = 10
.HorizontalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
.Range("A1:D1").Merge
End With
With .Range("A2").Resize(n, 5)
.Sort key1:=.Cells(1, 2), order1:=xlAscending, key2:=.Cells(1, 3), order2:=xlAscending, _
key3:=.Cells(1, 4), order3:=xlAscending, Header:=xlNo
.Sort key1:=.Cells(1, 5), order1:=xlDescending, key2:=.Cells(1, 1), order2:=xlAscending, _
key3:=.Cells(1, 2), order3:=xlAscending, Header:=xlNo
End With
End With
End Sub