Remove Odd Even check in macro only

[Excelnewbie001]

I have code that work out totals using amount of cells that can be set in D2 and D3.It will work out the total in D2 using D3 the amount off cells to use to get to D2(Add them together for the total of D2...I only need the code to remove the ODD EVEN test in the macro.The result must still string the numbers together like this example below. I am not a VBA programmer and dont know what in the code must be changed to get above results -ONLY the odd even must be taken out. Any help will be greatly appreciated. I am running Excel 2007.Tried too upload attachment of my book but the forum doesnt allow me ????

<colgroup><col style="mso-width-source:userset;mso-width-alt:6485;width:137pt" width="182"> </colgroup><tbody>
[TD="class: xl88, width: 182"]1, 3, 11 >> 5, 1, 5 5+1+5= 11 of D1 In the example 3 Odds =11

Sub GetCombosRev()
     
    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
    Dim var As Variant
    Dim lng As Long
     
    Set rngNumbers = Range("B2", Cells(Rows.Count, "A").End(xlUp).Offset(, 1))
    var = Application.Transpose(rngNumbers.Offset(, -1))
    Range("G2:G" & 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 + var(arrComboLoc(LocIndex))
            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
                str = str & " >> "
                For lng = LBound(arrOddEvenTest) To UBound(arrOddEvenTest)
                    str = str & var(arrOddEvenTest(lng)) & ", "
                Next lng
                str = Left(str, Len(str) - 2)
                colResults.Add str, str
            End If
        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("G2").Resize(colResults.Count).Value = Application.Transpose(arrResults)
        Range("G2").Resize(colResults.Count).Sort Range("G2")
    Else
        MsgBox "No valid combinations found to be less than or equal to " & dTargetSum & " when using " & Range("D3").Value & " cells."
    End If
     
End Sub

[/TD]

</tbody>

 

[hiker95]

Excelnewbie001,

Welcome to the MrExcel forum.


We would like more information. Please see the Forum Use Guidelines in the following link:

http://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html


See reply #2 at the next link, if you want to show small screenshots, of the raw data, and, what the results should look like.

http://www.mrexcel.com/forum/about-board/508133-attachments.html#post2507729


Or, you can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com