View Single Post
  #2   Report Post  
Gman41 Gman41 is offline
Junior Member
 
Posts: 3
Default

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