Home |
Search |
Today's Posts |
#1
|
|||
|
|||
Need help with a complicated macro (code change)
Goodday
Hope someone can help me with the following macro. This is what I hope to get achieved. Column A I have numbers repeat numbers aswell thats assigned to Column B Column B I have numbers 1-45 aswell thats assigned to Column A. In the following Macro what do I need to change so that the odd even get work out on column B instead of Column A as the range is 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 in column F. My aim is to list all available combination's 3 evens 3 odds that's equaled to the target sum But the target sum must be worked out with 6 combination's from Column A to give me the result of 58. The answer I am hoping to achieve is 13 18 24 39 43 4 from Column B for an total of 3 odds 3 evens but the formula can list all combination's that's 3 odds 3 evens that's equals to 58. So the odds evens must be set with column B but the total 58 must be set with all available combination's 6 of them to equal 58. What do I need to change in the code to achieve the results ? Any help greatly appreciated. Gman41 Sample attached |
#2
|
|||
|
|||
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 |
#3
|
|||
|
|||
Anyone all that I need done is to add a range......anyone please as its urgent for me to get it solved -thanks for any input
|
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Help with a very complicated For each Next code | Excel Programming | |||
Complicated Lookup Code | Excel Programming | |||
complicated change to formula (conintuous) | Excel Programming | |||
Help needed with Complicated code (For me !!) | Excel Programming | |||
Can I use code/macro to change code/macro in an existing file? | Excel Programming |