Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Junior Member
 
Posts: 3
Default 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
Attached Files
File Type: zip Sample.zip (72.3 KB, 46 views)
  #2   Report Post  
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
  #3   Report Post  
Junior Member
 
Posts: 3
Default

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
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
Help with a very complicated For each Next code Ayo Excel Programming 5 August 25th 09 06:34 PM
Complicated Lookup Code dkk Excel Programming 2 March 12th 09 02:11 PM
complicated change to formula (conintuous) theredspecial Excel Programming 5 December 27th 07 03:33 PM
Help needed with Complicated code (For me !!) Les Excel Programming 8 July 9th 07 02:28 PM
Can I use code/macro to change code/macro in an existing file? Scott Bedows Excel Programming 2 February 14th 07 06:50 AM


All times are GMT +1. The time now is 07:12 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"