Loop through and SUM total the ODD & EVEN Numbers.

[S.H.A.D.O.]

Good evening,

I would like to cycle through all the combinations and count the sum of the ODD numbers AND the sum of the EVEN numbers within each of the combination please.

I know the following:-
The LOWEST sum of ODD will be 0.
The LOWEST sum of EVEN will be 0.
The HIGHEST sum of ODD will be 264.
The HIGHEST sum of EVEN will be 258.

So, for example:-

06 24 30 39 46 49 = Odd 88 & Even 106
02 16 25 32 45 48 = Odd 70 & Even 98
03 20 27 29 36 47 = Odd 106 & Even 56
07 14 22 23 31 44 = Odd 61 & Even 80

So I will end up with the numbers from 0 to 264 in column A, the total for each of the sums of ODD numbers in column B and the total for each of the sums of EVEN numbers in column C.

Here is what I have so far but now I am stuck:-

Option Explicit
Option Base 1

Const MinA As Integer = 1
Const MaxF As Integer = 49

Sub Sum_Of_ODD_And_EVEN_Numbers()
    Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer
    Dim i As Integer
    Dim nType(0 To 264) As Double
    Dim sum As Long
    Dim results(49) As Long
    Dim nTypeTotal As Long
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    With Sheets("Results").Select
        Range("A:C").ClearContents
        Range("A1").Select
        For i = LBound(nType) To UBound(nType)
            nType(i) = 0
        Next i
        For i = MinA To MaxF
            results(i) = i Mod 2
        Next i
        For A = MinA To MaxF - 5
            For B = A + 1 To MaxF - 4
                For C = B + 1 To MaxF - 3
                    For D = C + 1 To MaxF - 2
                        For E = D + 1 To MaxF - 1
                            For F = E + 1 To MaxF
                                sum = results(A) + results(B) + results(C) + results(D) + results(E) + results(F)
                                nType(sum) = nType(sum) + 1
                            Next F
                        Next E
                    Next D
                Next C
            Next B
        Next A
        nTypeTotal = ActiveCell.Row
        With ActiveCell
            For i = LBound(nType) To UBound(nType)
                .Offset(i - LBound(nType), 0).Value = i
                .Offset(i - LBound(nType), 1).Value = nType(i)
            Next i
            .Offset(i - LBound(nType), 1).FormulaR1C1 = "=Sum(R" & nTypeTotal & "C:R[-1]C)"
        End With
    End With
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

Thanks in advance.

 

[S.H.A.D.O.]

Thanks for the reply Robert,

If you look at my code you will get an idea of what I am trying to do.
I just want it to loop through all the combinations in the For...Next loop and hold these totals in memory, then the only output will be the 264 rows of Odd & Even totals.
Thanks in advance.

 

[S.H.A.D.O.]

Well this is as far as I have got on this.
It is producing results but I think they are wrong because of the way I am trying to apply the Mod 2.
Any help will be appreciated.

Sub Sum_Of_ODD_And_EVEN_Numbers()
    Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer
    Dim i As Integer
    Dim nType(0 To 264) As Double
    Dim sum As Long
    Dim results(49) As Long
    Dim nTypeTotal As Long
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    With Sheets("Results").Select
        Range("A:C").ClearContents
        Range("A1").Select
        For i = LBound(nType) To UBound(nType)
            nType(i) = 0
        Next i
        For A = MinA To MaxF - 5
            For B = A + 1 To MaxF - 4
                For C = B + 1 To MaxF - 3
                    For D = C + 1 To MaxF - 2
                        For E = D + 1 To MaxF - 1
                            For F = E + 1 To MaxF
                                sum = (A + B + C + D + E + F Mod 2)
                                nType(sum) = nType(sum) + 1
                            Next F
                        Next E
                    Next D
                Next C
            Next B
        Next A
        nTypeTotal = ActiveCell.Row
        With ActiveCell
            For i = LBound(nType) To UBound(nType)
                .Offset(i - LBound(nType), 0).Value = i
                .Offset(i - LBound(nType), 1).Value = nType(i)
            Next i
            .Offset(i - LBound(nType), 1).FormulaR1C1 = "=Sum(R" & nTypeTotal & "C:R[-1]C)"
        End With
    End With
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

Thanks in advance.

 

[chirp]

try this out i think it is what you are looking for

note it will take on the order of minutes to run...not an ideal solution by any means

Option Explicit


'module level constants
Const MAX_INT As Long = 49
Const MAX_REC As Long = 6


'module level variables
Dim m_recLvl As Long
Dim m_dicE As Object
Dim m_dicO As Object


Sub custCount()
    Dim r_out As Range
    Dim v_odd As Variant, v_even As Variant, v_odd_out As Variant, v_even_out As Variant
    Dim v_odd_item As Variant, v_even_item As Variant
    
    Dim l_max As Long, i As Long
    
    'initialize dics
    Set m_dicE = CreateObject("scripting.dictionary")
    Set m_dicO = CreateObject("scripting.dictionary")
    
    'call recursive function
    doRecurse 1, 0, 0
    
    'we are "done" here but hassle to print these out (have a function for it)
    v_odd = m_dicO.keys
    v_even = m_dicE.keys
    v_odd_item = m_dicO.items
    v_even_item = m_dicE.items
    
    ReDim v_odd_out(1 To UBound(v_odd) + 1, 1 To 2)
    ReDim v_even_out(1 To UBound(v_even) + 1, 1 To 2)
    
    'just putting into format to print directly to sheet (could use transpose with this many values)
    For i = 1 To WorksheetFunction.Max(UBound(v_odd), UBound(v_even)) + 1
        If i - 1 <= UBound(v_odd) Then
            v_odd_out(i, 1) = v_odd(i - 1)
            v_odd_out(i, 2) = v_odd_item(i - 1)
        End If
        If i - 1 <= UBound(v_even) Then
            v_even_out(i, 1) = v_even(i - 1)
            v_even_out(i, 2) = v_even_item(i - 1)
        End If
    Next i
    
    'clear print and sort
    Columns("a:d").ClearContents
    [a1] = "Odd Sums": [b1] = "Odd Count"
    [c1] = "Even Sums": [d1] = "Even Count"
    
    Set r_out = Range([a2], [b2]).Resize(UBound(v_odd_out))
    r_out = v_odd_out
    r_out.Sort Key1:=[a2], Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
    Set r_out = Range([c2], [d2]).Resize(UBound(v_even_out))
    r_out = v_even_out
    r_out.Sort Key1:=[c2], Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    
End Sub


Function doRecurse(stInd As Long, evSum As Long, odSum As Long)
    Dim i As Long, j As Long, evAdd As Long, odAdd As Long
    
    m_recLvl = m_recLvl + 1
    
    For i = stInd To MAX_INT - MAX_REC + m_recLvl
        If m_recLvl < MAX_REC Then
            If i Mod 2 = 0 Then doRecurse i + 1, evSum + i, odSum Else doRecurse i + 1, evSum, odSum + i
        Else
            If i Mod 2 = 0 Then evAdd = i: odAdd = 0 Else odAdd = i: evAdd = 0
            m_dicE(evSum + evAdd) = m_dicE(evSum + evAdd) + 1
            m_dicO(odSum + odAdd) = m_dicO(odSum + odAdd) + 1
        End If
    Next i
    m_recLvl = m_recLvl - 1
End Function

 

[Trebor76]

Here's my attempt - I tweaked the code from an existing piece of code I had so I can't take much credit for it:

Option Explicit
Sub allLottery2()
    
    Dim x As Long
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    x = doTheLott("", 1, 1)
    
    With Application
        .StatusBar = False
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
    ActiveWorkbook.Save
    
End Sub
Function doTheLott(ByVal xStr As String, lngRowNum As Long, a As Integer) As Long
    
    Dim xArr As Variant, j As String, i As Integer, intArrayIndex As Integer, blnIsOdd As Boolean, dblMyTotalOdd As Double, dblMyTotalEven As Double
    
    xArr = Split(Trim(xStr), " ")
    
    If UBound(xArr) = 5 Then
    
        dblMyTotalOdd = 0
        dblMyTotalEven = 0
    
        For intArrayIndex = LBound(xArr) To UBound(xArr)
            blnIsOdd = Evaluate("SUMPRODUCT(--(MOD(" & Val(xArr(intArrayIndex)) & ",2)))")
            If blnIsOdd = True Then
                dblMyTotalOdd = dblMyTotalOdd + xArr(intArrayIndex)
            Else
                dblMyTotalEven = dblMyTotalEven + xArr(intArrayIndex)
            End If
        
        Next intArrayIndex
        
        If dblMyTotalOdd <= 264 And dblMyTotalEven <= 258 Then
            Cells(lngRowNum, "A").Value = xStr
            Cells(lngRowNum, "B").Value = dblMyTotalOdd
            Cells(lngRowNum, "C").Value = dblMyTotalEven
            lngRowNum = lngRowNum + 1
        End If
        
        If lngRowNum > Rows.Count Then
            Sheets.Add
            ActiveWorkbook.Save
            lngRowNum = 1
        End If
    
    Else
    
        For i = a To 49
            j = Format(i, "0")
            If InStr(xStr, j) = 0 Then
                lngRowNum = doTheLott(xStr & j & " ", lngRowNum, i)
            End If
        Next
        
    End If
    
    doTheLott = lngRowNum
    
End Function

Note it will create a new worksheet if the maximum number of rows is reached.

Robert

 

[chirp]

hey Robert,

not sure if you ran the code but wouldn't that loop take a significant amount of time, on the order of hours?

I understood the problem as wanting to count the number of times the even/odd sum reached a particular value, not all the combinations.

so for say 4 choose 3 you would have:

1,2,3
1,2,4
1,3,4
2,3,4

which would have the odd sums:

sum 1 occurrence 1
sum 3 occurrence 1
sum 4 occurrence 2

and for the even sums:

sum 2 occurrence 1
sum 4 occurrence 1
sum 6 occurrence 2

where the sum of the occurrences would equal the (n choose k) term, but the number of sums would only be roughly the top k terms

could be wrong on this though, but that is how i implemented it

 

[Trebor76]

Hi chirp,

You may be right. I did think the combinations that made the odd/even total were required hence my reluctance to do the task in Excel.

I might have a look at your clever solution and if I have any queries I might come back to you (hope that's OK).

Robert

 

[chirp]

not that clever at all

just came back to this thread and had no idea what i was doing with dictionaries

dictionaries solve so many problems that it is almost default to use in this sort of situation, anyway here is a much better version:

Option Explicit


'module level constants
Const MAX_INT As Long = 49
Const MAX_REC As Long = 6


'module level variables
Dim m_recLvl As Long
Dim m_ArrE() As Long
Dim m_ArrO() As Long


Sub custCount1()
    Dim i As Long, l_cntE As Long, l_cntO As Long
    Dim v_outE As Variant, v_outO As Variant
    'initialize arrays
    ReDim m_ArrE(0 To MAX_REC * MAX_INT)
    ReDim m_ArrO(0 To MAX_REC * MAX_INT)
    
    'call recursive function
    doRecurse 1, 0, 0


    'convert to variant
    ReDim v_outE(1 To UBound(m_ArrE), 1 To 2)
    ReDim v_outO(1 To UBound(m_ArrO), 1 To 2)
    
    For i = 0 To UBound(m_ArrE)
        If m_ArrE(i) > 0 Then
            l_cntE = l_cntE + 1
            v_outE(l_cntE, 1) = i
            v_outE(l_cntE, 2) = m_ArrE(i)
        End If
        If m_ArrO(i) > 0 Then
            l_cntO = l_cntO + 1
            v_outO(l_cntO, 1) = i
            v_outO(l_cntO, 2) = m_ArrO(i)
        End If
    Next i


    'clear print and sort
    Columns("a:d").ClearContents
    [a1] = "Even Sum": [b1] = "Even Count"
    [c1] = "Odd Sum": [D1] = "Odd Count"
    Range([a2], [b2]).Resize(l_cntE) = v_outE
    Range([c2], [D2]).Resize(l_cntO) = v_outO
End Sub


Function doRecurse(stInd As Long, evSum As Long, odSum As Long)
    Dim i As Long, j As Long, evAdd As Long, odAdd As Long


    m_recLvl = m_recLvl + 1
    For i = stInd To MAX_INT - MAX_REC + m_recLvl
        If m_recLvl < MAX_REC Then
            If i Mod 2 = 0 Then doRecurse i + 1, evSum + i, odSum Else doRecurse i + 1, evSum, odSum + i
        Else
            If i Mod 2 = 0 Then evAdd = i: odAdd = 0 Else odAdd = i: evAdd = 0
            m_ArrE(evSum + evAdd) = m_ArrE(evSum + evAdd) + 1
            m_ArrO(odSum + odAdd) = m_ArrO(odSum + odAdd) + 1
        End If
    Next i
    m_recLvl = m_recLvl - 1
End Function

 

[S.H.A.D.O.]

Thanks Robert & chirp for your replies and time.

chirp,

I ran your code which ran very fast indeed.
I did the calculations and tested your code on C(8,6)=28 combinations, and it works brilliantly, thanks very much indeed.

Just one point, I couldn't work out how to amend the code for it to include the ZERO occurances, but not a biggie.
I will go through your code and try and work out exactly how it works and what it is doing.
Thanks VERY much again and enjoy the rest of your weekend.

 

[chirp]

Haven't really tested the changes but this should do that, note a fun little formula for calculating the max sum...could be simplified but you get the idea:

Option Explicit


'module level constants
Const MAX_INT As Long = 49
Const MAX_REC As Long = 6


'module level variables
Dim m_recLvl As Long
Dim m_ArrE() As Long
Dim m_ArrO() As Long


Sub custCount1()
    Dim i As Long, l_cntE As Long, l_cntO As Long, l_max As Long
    Dim v_outE As Variant, v_outO As Variant
    
    'this is a (rather messy not simplified) formula to calculate the maximum
    'sum [uses fact sum 1-n=n*(n+1)/2]
    l_max = MAX_INT * (MAX_INT + 1) / 2 - (MAX_INT - MAX_REC) * (MAX_INT - MAX_REC + 1) / 2 - Int(MAX_REC / 2) * (MAX_REC - 1) - 2 * (MAX_REC Mod 2)
    
    'initialize arrays
    ReDim m_ArrE(0 To l_max)
    ReDim m_ArrO(0 To l_max)
    
    'call recursive function
    doRecurse 1, 0, 0


    'convert to variant
    ReDim v_outE(1 To l_max + 1, 1 To 2)
    ReDim v_outO(1 To l_max + 1, 1 To 2)
    
    For i = 0 To l_max
            v_outE(i + 1, 1) = i
            v_outE(i + 1, 2) = m_ArrE(i)


            v_outO(i + 1, 1) = i
            v_outO(i + 1, 2) = m_ArrO(i)
    Next i


    'clear print and sort
    Columns("a:d").ClearContents
    [a1] = "Even Sum": [b1] = "Even Count"
    [c1] = "Odd Sum": [D1] = "Odd Count"
    Range([a2], [b2]).Resize(UBound(v_outE)) = v_outE
    Range([c2], [D2]).Resize(UBound(v_outO)) = v_outO
End Sub


Function doRecurse(stInd As Long, evSum As Long, odSum As Long)
    Dim i As Long, j As Long, evAdd As Long, odAdd As Long


    m_recLvl = m_recLvl + 1
    For i = stInd To MAX_INT - MAX_REC + m_recLvl
        If m_recLvl < MAX_REC Then
            If i Mod 2 = 0 Then doRecurse i + 1, evSum + i, odSum Else doRecurse i + 1, evSum, odSum + i
        Else
            If i Mod 2 = 0 Then evAdd = i: odAdd = 0 Else odAdd = i: evAdd = 0
            m_ArrE(evSum + evAdd) = m_ArrE(evSum + evAdd) + 1
            m_ArrO(odSum + odAdd) = m_ArrO(odSum + odAdd) + 1
        End If
    Next i
    m_recLvl = m_recLvl - 1
End Function

 

[S.H.A.D.O.]

Hi chirp,

Works perfectly thank you, you are an absoulute star.