This is the code in question
Sub GetCombos()
Dim rngNumbers As Range
Dim i As Long, j As Long, k As Long
Dim colResults As New Collection
Dim arrResults() As String
Dim arrOddEvenTest() As String
Dim arrComboLoc As Variant
Dim LocIndex As Long
Dim TestIndex As Long
Dim dTot As Double
Dim str As String
Dim dTargetSum As Double
Dim bAdvanced As Boolean
Dim bValid As Boolean
Dim lNumOdd As Long, lTotOdd As Long
Dim lNumEven As Long, lTotEven As Long
Set rngNumbers = Range("A2", Cells(Rows.Count, "A").End(xlUp))
Range("F2:F" & Rows.Count).ClearContents
If Not IsNumeric(Range("D2").Value) _
Or Len(Trim(Range("D2").Value)) = 0 Then
Range("D2").Select
MsgBox "Must provide a Target SUM number"
Exit Sub
End If
If Not IsNumeric(Range("D3").Value) _
Or Len(Trim(Range("D3").Value)) = 0 Then
Range("D3").Select
MsgBox "Must provide the number of cells to use"
Exit Sub
ElseIf Range("D3").Value rngNumbers.Cells.Count Then
Range("D3").Select
MsgBox "Number of cells may not exceed total amount of cells"
Exit Sub
ElseIf Range("D3").Value < 1 Then
Range("D3").Select
MsgBox "Number of cells may not be less than 1"
Exit Sub
End If
If Not IsNumeric(Range("D4").Value) _
Or Len(Trim(Range("D4").Value)) = 0 Then
Range("D4").Select
MsgBox "Must provide the # of Odds required"
Exit Sub
End If
dTargetSum = Range("D2").Value
arrComboLoc = Application.Transpose(Evaluate("Index(Row(1:" & Range("D3").Value & "),)"))
lNumOdd = Range("D4").Value
lNumEven = Range("D5").Value
On Error Resume Next
For i = 1 To WorksheetFunction.Combin(rngNumbers.Count, Range("D3").Value)
dTot = 0
str = vbNullString
For LocIndex = LBound(arrComboLoc) To UBound(arrComboLoc)
dTot = dTot + rngNumbers.Cells(arrComboLoc(LocIndex)).Value
str = str & ", " & rngNumbers.Cells(arrComboLoc(LocIndex)).Value
Next LocIndex
If dTot = dTargetSum Then
str = Mid(str, 3)
lTotOdd = 0
lTotEven = 0
bValid = True
arrOddEvenTest = Split(str, ", ")
For TestIndex = LBound(arrOddEvenTest) To UBound(arrOddEvenTest)
If arrOddEvenTest(TestIndex) = 0 Then
lTotOdd = lTotOdd + 1
If lTotOdd lNumOdd Then
bValid = False
Exit For
End If
Else
Select Case (arrOddEvenTest(TestIndex) / 2 = Int(arrOddEvenTest(TestIndex) / 2))
Case True: lTotEven = lTotEven + 1
If lTotEven lNumEven Then
bValid = False
Exit For
End If
Case Else: lTotOdd = lTotOdd + 1
If lTotOdd lNumOdd Then
bValid = False
Exit For
End If
End Select
End If
Next TestIndex
If bValid = True Then colResults.Add str, str
End If
bAdvanced = False
For j = UBound(arrComboLoc) To LBound(arrComboLoc) Step -1
If arrComboLoc(j) < rngNumbers.Cells.Count - (UBound(arrComboLoc) - j) Then
arrComboLoc(j) = arrComboLoc(j) + 1
For k = j + 1 To UBound(arrComboLoc)
arrComboLoc(k) = arrComboLoc(j) + k - j
Next k
bAdvanced = True
Exit For
End If
If bAdvanced = True Then Exit For
Next j
Next i
If colResults.Count 0 Then
ReDim Preserve arrResults(1 To colResults.Count)
For i = 1 To colResults.Count
arrResults(i) = colResults(i)
Next i
Range("F2").Resize(colResults.Count).Value = Application.Transpose(arrResults)
Else
MsgBox "No valid combinations found to be less than or equal to " & dTargetSum & " when using " & Range("D3").Value & " cells."
End If
End Sub
|