Oops, now I left out the first two lines: Hopefully this will run if you
copy and paste it from the email.

Sub tester9()
Dim bWrite As Boolean
Dim arr(0 To 19) As Long
Dim arr1(1 To 6) As Long
Dim arr2(0 To 19) As Long
Dim col(1 To 4) As Long
Dim cnt As Long, ii As Long
Dim j As Long, i As Long, k As Long
Dim m As Long, cell As Range, colm As Range
'Dim sStr as String
i = -1
For Each colm In Range("A1:D5").Columns
For Each cell In colm.Cells
i = i + 1
arr2(i) = cell.Value
Next
Next
j = 7
For i = 1 To 2 ^ 20 - 1
bldArr i, arr, cnt
If cnt = 6 Then
For ii = 1 To 4
col(ii) = 0
arr1(ii) = Empty
Next
arr1(5) = Empty
arr1(6) = Empty
m = 1
' sStr = ""
For k = 0 To 19
' sStr = sStr & arr(k)
If arr(k) = 1 Then
arr1(m) = arr2(k)
m = m + 1
bWrite = False
Select Case k
Case 0, 1, 2, 3, 4
col(1) = col(1) + 1
If col(1) 2 Then Exit For
Case 5, 6, 7, 8, 9
col(2) = col(2) + 1
If col(2) 2 Then Exit For
Case 10, 11, 12, 13, 14
col(3) = col(3) + 1
If col(3) 2 Then Exit For
Case 15, 16, 17, 18, 19
col(4) = col(4) + 1
If col(4) 2 Then Exit For
End Select
bWrite = True
End If
Next
' Debug.Print i, sStr, m
For ii = 1 To 4
If col(ii) = 0 Then
bWrite = False
Exit For
End If
Next
If bWrite Then
Cells(j, 1).Resize(1, 6).Value = arr1
' Cells(j, 7) = i
' Cells(j, 8).Resize(1, 20) = arr
j = j + 1
End If
End If
Next

End Sub

Sub bldArr(num As Long, arr() As Long, cnt As Long)
Dim lNum As Long, i As Long
lNum = num
' Dim sStr As String
' sStr = ""
cnt = 0
For i = 19 To 0 Step -1
If lNum And 2 ^ i Then
cnt = cnt + 1
arr(19 - i) = 1
' sStr = sStr & "1"
If cnt 6 Then Exit Sub
Else
arr(19 - i) = 0
' sStr = sStr & "0"
End If
Next
' If cnt = 2 Then
' Debug.Print num, sStr
' End If
End Sub

--
Regards,
Tom Ogilvy