Public Sub FindCombos()
Dim setSize As Long
Dim lastCol As Long
Dim thisCol As Long
Dim elCount As Long
Dim i As Long
Dim j As Long
Dim total As Long
Dim solution As String
Dim selectedCells() As Range
Dim rowStart() As Long
Dim setCount() As Long
Dim lastRow As Long
Dim nextRow As Long
Dim allOK As Boolean
' Clear out the solutions
Sheets("Solutions").Cells.ClearContents
' Find the last group and the number of elements we're going to pick
lastCol = Cells(3, Columns.Count).End(xlToLeft).Column
setSize = Application.WorksheetFunction.Sum(Range(Cells(4, 2), Cells(4, lastCol)))
' Set up the arrays
ReDim selectedCells(setSize) As Range
ReDim rowStart(lastCol) As Long
ReDim setCount(lastCol) As Long
' Set the initial selection
i = 1
Set selectedCells(0) = Cells(1, 1)
For thisCol = 2 To lastCol
For elCount = 1 To Cells(4, thisCol).Value
Set selectedCells(i) = Cells(4 + elCount, thisCol)
i = i + 1
Next elCount
Next thisCol
' Uniquely name each element in the groups
rowStart(2) = 97
For thisCol = 2 To lastCol
lastRow = Cells(Rows.Count, thisCol).End(xlUp).Row
setCount(thisCol) = lastRow - 4
If thisCol < lastCol Then rowStart(thisCol + 1) = rowStart(thisCol) + setCount(thisCol)
Next thisCol
' Next solution row
nextRow = 1
' Keep going until we've exhausted all possibilities
Do While True
' Check the current total
total = 0
For i = 1 To setSize
total = total + selectedCells(i).Value
Next i
' Total is in range?
If total >= Cells(1, 2).Value And total <= Cells(2, 2).Value Then
' Generate the solution
solution = ""
For i = 1 To setSize
solution = solution & Chr$(rowStart(selectedCells(i).Column) + selectedCells(i).Row - 5)
Next i
' Print the solution on the solution sheet
Sheets("Solutions").Cells(nextRow, 1).Value = solution
nextRow = nextRow + 1
End If
' Tick over to the next selection
i = setSize
Do While True
' Move the cell down
Set selectedCells(i) = selectedCells(i).Offset(1, 0)
' OK?
If selectedCells(i).Value = "" Then
' Move this back to the top
Set selectedCells(i) = Cells(5, selectedCells(i).Column)
' Move to the previous cell and move that
i = i - 1
Else
allOK = True
' Adjust all other cells
If i < setSize Then
For j = i + 1 To setSize
If selectedCells(j).Column = selectedCells(i).Column Then
Set selectedCells(j) = selectedCells(j - 1).Offset(1, 0)
If selectedCells(j).Value = "" Then
i = i - 1
allOK = False
Exit For
End If
End If
Next j
End If
' Column exhausted
If allOK Or i = 0 Then Exit Do
' Reset column?
If selectedCells(i).Column <> selectedCells(i + 1).Column Then
Set selectedCells(i + 1) = Cells(5, selectedCells(i + 1).Column)
For j = i + 2 To setSize
If selectedCells(j).Column = selectedCells(j - 1).Column Then
Set selectedCells(j) = selectedCells(j - 1).Offset(1, 0)
End If
Next j
End If
End If
' Done?
If i = 0 Then Exit Do
Loop
' Finished?
If i = 0 Then Exit Do
Loop
End Sub
