"joeu2004" wrote in message
...
"Peter T" wrote:
I knocked something up to get a feel, pretty crude
and slow but it churned out 1,947,792 combinations
of 6 numbers of which 16,431 fitted your '4 out of 6' criteria.

I would like to understand why you and I got very different results.

Please upload your results -- the 16,431 combinations -- to a file-sharing
website

16,431, after spotting a small error now only 16,430

It's small enough to post here, but watch for word wrap -

Option Explicit
Sub test6()
Dim i As Long, j As Long
Dim s As String
Dim arrCombs() As Long

Range("a:a").Clear

Combs4from6 arrCombs, 36

For i = 1 To UBound(arrCombs, 2)
s = arrCombs(1, i)
For j = 2 To 6
s = s & " " & arrCombs(j, i)
Next
Cells(i, 1) = s
Next

End Sub

Function Combs4from6(bigArr, mx As Long) As Long
Dim a1 As Long, a2 As Long, a3 As Long, a4 As Long, a5 As Long, a6 As Long
Dim i As Long, j As Long
Dim r As Long, x As Long

ReDim arr(1 To 6) As Long
ReDim bigArr(1 To 6, 1 To 1000) As Long

For a1 = mx - (mx - 6) + 1 To mx
arr(1) = arr(1) + 1
arr(2) = arr(1)
For a2 = a1 - 1 To mx
arr(2) = arr(2) + 1
arr(3) = arr(2)
For a3 = a2 To mx
arr(3) = arr(3) + 1
arr(4) = arr(3)
For a4 = a3 To mx
arr(4) = arr(4) + 1
arr(5) = arr(4)
For a5 = a4 To mx
arr(5) = arr(5) + 1
arr(6) = arr(5)
For a6 = a5 To mx
arr(6) = arr(6) + 1
r = r + 1
filterComb bigArr, arr, x
Next
Next
Next
Next
Next
Next

' the last one
For i = 1 To 6
arr(i) = mx - 6 + i
Next
filterComb bigArr, arr, x

ReDim Preserve bigArr(1 To 6, 1 To x)

Combs4from6 = x
End Function
Function filterComb(bigArr, arr() As Long, x As Long) As Boolean
Dim b As Boolean
Dim i As Long, j As Long, k As Long
Dim f As Long

On Error GoTo errH

If x < 1 Then
x = x + 1
For i = 1 To 6
bigArr(i, 1) = arr(i)
Next
filterComb = True
Else

For i = 1 To x
f = 0

For j = 1 To 6
For k = 1 To 6
If bigArr(j, x) = arr(k) Then
b = True
Exit For
End If
Next

If b Then
f = f + 1
b = False
If f = 4 Then
' already found 4 dups, no point to look for more
Exit Function
End If
End If

If j - f 2 Then
' can't be 4 dups in this array so skip to the next
Exit For
End If

Next
Next

x = x + 1
For i = 1 To 6
999 bigArr(i, x) = arr(i)
Next
filterComb = True
End If

Exit Function
errH:
If Err.Number = 9 And Erl = 999 Then
'need to resize the array
ReDim Preserve bigArr(1 To 6, 1 To UBound(bigArr, 2) + 1000)
Resume
End If

End Function

It works like this
- Combs4from6 makes all the 6-number combinations, each temporarily to a 6
number array.
- filterComb compares the array looking for 4 duplicate numbers in all
previously retained arrays. If 4 dups are not found the array of 6 is added
to the main array

Combs4from6 is I think highly efficient and well optimzed. filterComb is
'efficient' but the entire approach isn't. If filterComb is commented in
Combs4from6 1.9m combinations are produced in barely a tad. However the
filter approach means take a coffee or two. Probably a different approach
would speed things up considerably. In particular, look into only making
correct combinations (rather than all 1.9m) in the first place and avoid the
need to filter; it's one of those "'get your head round it' sort of things!

I have NOT checked results, so until otherwise confirmed do not assume this
all works correctly!

Regards,
Peter T