Need help with a complicated macro (code change)

[Gman41]

Goodday

Hope someone can help me with the following macro. This is what I hop
to get achieved. Column A I have numbers repeat numbers aswell that
assigned to Column B Column B I have numbers 1-45 aswell thats assigne
to Column A. In the following Macro what do I need to change so that th
odd even get work out on column B instead of Column A as the range i
set on Column A BUT very important Now for the tricky part


I have a target Sum that's my aim to get to an array Combination's i
column F. My aim is to list all available combination's 3 evens 3 odd
that's equaled to the target sum But the target sum must be worked ou
with 6 combination's from Column A to give me the result of 58. Th
answer I am hoping to achieve is 13 18 24 39 43 4 from Column B for a
total of 3 odds 3 evens but the formula can list all combination'
that's 3 odds 3 evens that's equals to 58. So the odds evens must be se
with column B but the total 58 must be set with all availabl
combination's 6 of them to equal 58. What do I need to change in th
code to achieve the results ? Any help greatly appreciated.

Gman41

Sample attache

+-------------------------------------------------------------------
|Filename: Sample.zip
|Download: http://www.excelbanter.com/attachment.php?attachmentid=599
+-------------------------------------------------------------------

 

[Gman41]

This is the code in questio

Sub GetCombos(

Dim rngNumbers As Rang
Dim i As Long, j As Long, k As Lon
Dim colResults As New Collectio
Dim arrResults() As Strin
Dim arrOddEvenTest() As Strin
Dim arrComboLoc As Varian
Dim LocIndex As Lon
Dim TestIndex As Lon
Dim dTot As Doubl
Dim str As Strin
Dim dTargetSum As Doubl
Dim bAdvanced As Boolea
Dim bValid As Boolea
Dim lNumOdd As Long, lTotOdd As Lon
Dim lNumEven As Long, lTotEven As Lon

Set rngNumbers = Range("A2", Cells(Rows.Count, "A").End(xlUp)
Range("F2:F" & Rows.Count).ClearContent

If Not IsNumeric(Range("D2").Value)
Or Len(Trim(Range("D2").Value)) = 0 The
Range("D2").Selec
MsgBox "Must provide a Target SUM number
Exit Su
End I

If Not IsNumeric(Range("D3").Value)
Or Len(Trim(Range("D3").Value)) = 0 The
Range("D3").Selec
MsgBox "Must provide the number of cells to use
Exit Su
ElseIf Range("D3").Value > rngNumbers.Cells.Count The
Range("D3").Selec
MsgBox "Number of cells may not exceed total amount of cells
Exit Su
ElseIf Range("D3").Value < 1 The
Range("D3").Selec
MsgBox "Number of cells may not be less than 1
Exit Su
End I

If Not IsNumeric(Range("D4").Value)
Or Len(Trim(Range("D4").Value)) = 0 The
Range("D4").Selec
MsgBox "Must provide the # of Odds required
Exit Su
End I

dTargetSum = Range("D2").Valu
arrComboLoc = Application.Transpose(Evaluate("Index(Row(1:"
Range("D3").Value & "),)")
lNumOdd = Range("D4").Valu
lNumEven = Range("D5").Valu

On Error Resume Nex
For i = 1 To WorksheetFunction.Combin(rngNumbers.Count
Range("D3").Value
dTot =
str = vbNullStrin
For LocIndex = LBound(arrComboLoc) To UBound(arrComboLoc
dTot = dTot + rngNumbers.Cells(arrComboLoc(LocIndex)).Valu
str = str & ", "
rngNumbers.Cells(arrComboLoc(LocIndex)).Valu
Next LocInde
If dTot = dTargetSum The
str = Mid(str, 3
lTotOdd =
lTotEven =
bValid = Tru
arrOddEvenTest = Split(str, ", "
For TestIndex = LBound(arrOddEvenTest) T
UBound(arrOddEvenTest
If arrOddEvenTest(TestIndex) = 0 The
lTotOdd = lTotOdd +
If lTotOdd > lNumOdd The
bValid = Fals
Exit Fo
End I
Els
Select Case (arrOddEvenTest(TestIndex) / 2
Int(arrOddEvenTest(TestIndex) / 2)
Case True: lTotEven = lTotEven +
If lTotEven > lNumEven The
bValid = Fals
Exit Fo
End I
Case Else: lTotOdd = lTotOdd +
If lTotOdd > lNumOdd The
bValid = Fals
Exit Fo
End I
End Selec
End I
Next TestInde
If bValid = True Then colResults.Add str, st
End I

bAdvanced = Fals
For j = UBound(arrComboLoc) To LBound(arrComboLoc) Step -
If arrComboLoc(j) < rngNumbers.Cells.Count
(UBound(arrComboLoc) - j) The
arrComboLoc(j) = arrComboLoc(j) +
For k = j + 1 To UBound(arrComboLoc
arrComboLoc(k) = arrComboLoc(j) + k -
Next
bAdvanced = Tru
Exit Fo
End I
If bAdvanced = True Then Exit Fo
Next
Next

If colResults.Count > 0 The
ReDim Preserve arrResults(1 To colResults.Count
For i = 1 To colResults.Coun
arrResults(i) = colResults(i
Next
Range("F2").Resize(colResults.Count).Value
Application.Transpose(arrResults
Els
MsgBox "No valid combinations found to be less than or equal t
" & dTargetSum & " when using " & Range("D3").Value & " cells.
End I

End Su

+-------------------------------------------------------------------
+-------------------------------------------------------------------

 

[Gman41]

Anyone all that I need done is to add a range......anyone please as it
urgent for me to get it solved -thanks for any inpu

+-------------------------------------------------------------------
+-------------------------------------------------------------------