Sub Test1()
Dim lNos As Long, lNoGroups As Long, lGroupSize() As Long, i As Long
lNos = 10
lNoGroups = 3
ReDim lGroupSize(1 To lNoGroups)
lGroupSize(1) = 3
lGroupSize(2) = 4
lGroupSize(3) = 3
With Sheets("Sheet1")
.Rows(1).ClearContents
.Range("A1:C1").Value = "Group1"
.Range("D1:G1").Value = "Group2"
.Range("H1:J1").Value = "Group3"
Call MakeGroups(lNos, lGroupSize, .Range("A2"))
End With
End Sub
Sub MakeGroups(lNos As Long, lGroupSize() As Long, rngOutput As Range)
Dim lNoGroups As Long, lCount1 As Long, lCount2 As Long, lProduct As Long
Dim lTemp() As Long, lCombinations() As Long, lNoCombinations() As Long
Dim lNumbers() As Long, lNosRemaining As Long, h As Long, i As Long, j As Long, k As Long
Dim lGroupSizeCumulative As Long, lProductCumulative As Long, lIndex1 As Long, lIndex2 As Long
Dim bUsed() As Boolean
lNoGroups = UBound(lGroupSize)
ReDim lNoCombinations(1 To lNoGroups)
lNosRemaining = lNos
lProduct = 1
For i = 1 To lNoGroups
lNoCombinations(i) = WorksheetFunction.Combin(lNos - lCount1, lGroupSize(i))
lCount1 = lCount1 + lGroupSize(i)
lProduct = lProduct * lNoCombinations(i)
Next i
ReDim lCombinations(1 To lProduct, 1 To lCount1)
'Group 1
lProductCumulative = lNoCombinations(1)
lTemp = GetCombinations(lNos, lGroupSize(1))
For i = 1 To lNoCombinations(1)
For j = 1 To lProduct / lNoCombinations(1)
For k = 1 To lGroupSize(1)
lCombinations(lProduct / lNoCombinations(1) * (i - 1) + j, k) = lTemp(i, k)
Next k
Next j
Next i
'Remaining Groups
For h = 2 To lNoGroups
lNosRemaining = lNosRemaining - lGroupSize(h - 1)
lGroupSizeCumulative = lGroupSizeCumulative + lGroupSize(h - 1)
lProductCumulative = lProductCumulative * lNoCombinations(h)
ReDim lNumbers(1 To lNosRemaining)
For i = 1 To lProduct / lProductCumulative
For j = 1 To lProductCumulative
lIndex1 = (i - 1) * lProductCumulative + j
If lNoCombinations(h) = 1 _
Or lIndex1 Mod lNoCombinations(h) * lProduct / lProductCumulative = 1 Then
ReDim bUsed(1 To lNos)
lCount2 = 0
For k = 1 To lGroupSizeCumulative
bUsed(lCombinations(lIndex1, k)) = True
Next k
For k = 1 To lNos
If Not bUsed(k) Then
lCount2 = lCount2 + 1
lNumbers(lCount2) = k
End If
Next k
lTemp = GetCombinations(lNosRemaining, lGroupSize(h))
End If
lIndex1 = lProductCumulative * (i - 1) + j
lIndex2 = 1 + Int((lIndex1 - 1) / (lProduct / lProductCumulative)) Mod lNoCombinations(h)
For k = 1 To lGroupSize(h)
lCombinations(lIndex1, lGroupSizeCumulative + k) _
= lNumbers(lTemp(lIndex2, k))
Next k
Next j
Next i
Next h
On Error Resume Next
Range("MyGroups").ClearContents
On Error GoTo 0
With rngOutput.Resize(lProduct, lCount1)
.Value = lCombinations
.Name = "MyGroups"
End With
End Sub
Function GetCombinations(lNumber As Long, lNoChosen As Long) As Long()
Dim lOutput() As Long, lCombinations As Long
Dim i As Long, j As Long, k As Long
lCombinations = WorksheetFunction.Combin(lNumber, lNoChosen)
ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
For i = 1 To lNoChosen
lOutput(1, i) = i
Next i
For i = 2 To lCombinations
For j = 1 To lNoChosen
lOutput(i, j) = lOutput(i - 1, j)
Next j
For j = lNoChosen To 1 Step -1
lOutput(i, j) = lOutput(i, j) + 1
If lOutput(i, j) <= lNumber - (lNoChosen - j) Then Exit For
Next j
For k = j + 1 To lNoChosen
lOutput(i, k) = lOutput(i, k - 1) + 1
Next k
Next i
GetCombinations = lOutput
End Function
