Loop through combinations and add only Even & Odd numbers together within each.

[PAB]

Good morning,

Firstly, I have also posted this exact same request here but with no luck as of yet...

http://www.mrexcel.com/forum/excel-questions/944378-loop-through-combinations-add-only-even-odd-numbers-together-within-each-combination.html

I tried posting a similar question before but I think it got too confusing, so I am changing my requirements and taking a step back and this will hopefully be more explanatory.

I want to produce 4 columns of data, which are as follows...

Column A, Even Sum
Column B, Total Combinations
Column C, Odd Sum
Column D, Total Combinations

The Even Sum (Column A) is made up from looping through all the combinations of COMBIN(59,6) individually and adding together ONLY those numbers that are Even within each combination.

For example, the combination 02, 21, 28, 39, 48, 56 would become Even Sum 02 + 28 + 48 + 56 = 134.
Then in column B, the Total Combinations is the total of all those individual combinations where the Even Sum adds up to 134 for example. The Even Sum range is from 0 to 318.

The same logic applies to the Odd Sum. The Odd Sum range is from 0 to 324.

I have the following code which runs as a standalone code and outputs the data into the WorkSheet.
This work great, but I would ideally like the code adapted so it produces exactly the same results and output but without using a Function please.

I have attached the file containing the output and code.

Thanks in advance.

[mdmackillop]

So you want the doRecurse function replace by some other Sub routine. Is that correct? Curious but why?

Option Explicit
Option Base 1


Const Drawn As Long = 6
Const MaxF As Long = 59

Dim nEven() As Long
Dim nOdd() As Long
Dim m_recLvl As Long


Sub Odd_And_Even()
Dim vEven As Variant, vOdd As Variant
Dim i As Long
Dim CountEven As Long, CountOdd As Long
Dim lRow As Long
Dim MyDist As Variant
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Columns("A:F").ClearContents
Cells(1, 1).Select

ReDim nEven(0 To Drawn * MaxF)
ReDim nOdd(0 To Drawn * MaxF)

Call doRecurse(1, 0, 0)


With ActiveCell
ReDim vEven(1 To UBound(nEven), 1 To 2)
ReDim vOdd(1 To UBound(nOdd), 1 To 2)

For i = 0 To UBound(nEven)
If nEven(i) > 0 Then
CountEven = CountEven + 1
vEven(CountEven, 1) = i
vEven(CountEven, 2) = nEven(i)
End If
If nOdd(i) > 0 Then
CountOdd = CountOdd + 1
vOdd(CountOdd, 1) = i
vOdd(CountOdd, 2) = nOdd(i)
End If
Next i

lRow = ActiveCell.Row


MyDist = Array("Even Sum", "Total Combinations", "Odd Sum", "Total Combinations")
ActiveCell.Offset(0, 0).Resize(UBound(MyDist), 4) = MyDist


ActiveCell.Offset(1, 0).Resize(CountEven, 2) = vEven
ActiveCell.Offset(1, 2).Resize(CountOdd, 2) = vOdd

ActiveCell.Offset(CountEven + 1, 1).FormulaR1C1 = "=Sum(R" & lRow + 1 & "C:R[-1]C)"
ActiveCell.Offset(CountOdd + 1, 3).FormulaR1C1 = "=Sum(R" & lRow + 1 & "C:R[-1]C)"
End With


With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub


Sub doRecurse(stInd As Long, EvenSum As Long, OddSum As Long)
Dim i As Long
Dim EvenAdd As Long, OddAdd As Long


m_recLvl = m_recLvl + 1


For i = stInd To MaxF - Drawn + m_recLvl
If m_recLvl < Drawn Then
If i Mod 2 = 0 Then
Call doRecurse(i + 1, EvenSum + i, OddSum)
Else
Call doRecurse(i + 1, EvenSum, OddSum + i)
End If
Else
If i Mod 2 = 0 Then
EvenAdd = i: OddAdd = 0
Else
OddAdd = i: EvenAdd = 0
End If
nEven(EvenSum + EvenAdd) = nEven(EvenSum + EvenAdd) + 1
nOdd(OddSum + OddAdd) = nOdd(OddSum + OddAdd) + 1
End If
Next i


m_recLvl = m_recLvl - 1
End Sub

[PAB]

Thanks for the reply mdmackillop, it is appreciated.

This is not my code and was written about three or four years ago, and to be honest, I am finding it hard to understand, let alone adapt it.

My ultimate aim is to take the output the code produces one step further, and just thought that code without a Function would make it easier for me to understand and adapt, rightly or wrongly.

What I am trying to do is to work out the Root, and the assocciated sum totals. By that I mean, if the Even Sum was 68, then the 68 would become 14, i.e. 6+8=14, and the assocciated sum total for all those that = 14. This will be the same for all the others. The same logic applies to the Odd. It basically adds the digits together once for all the Even Sum and Odd Sum totals and then produces the totals for them, as in the table below.

I have tried with the existing code to manipulate the Mod 2 and to wrap the formula below around different parts of the code to get it to work, but unfortunately to no avail. I am at a loss really.

If it was an Excel formula it would be something like this...


=SUMPRODUCT(INT(n/10)+MOD(n,10))

...where n is the sum total to be converted to the Root total.

Adapting the code should produce the following results.



Even Root

Total

Odd Root

Total



0

593775

0

475020



1

931219

1

508186



2

1128960

2

969170



3

1910151

3

1514005



4

2113077

4

2013686



5

2959057

5

2564644



6

3150173

6

3101952



7

3951335

7

3508256



8

4063775

8

4031773



9

4859074

9

4429432



10

3970785

10

4474431



11

3915585

11

3932869



12

3002865

12

3517766



13

2931468

13

2912104



14

1942982

14

2456150



15

1790248

15

1834815



16

950704

16

1393783



17

838264

17

894017



18

53942

18

487238



19

35

19

38177




45057474


45057474




I hope I have explained this clearly enough.

Thanks in advance.

[mdmackillop]

Change to this


For i = 0 To UBound(nEven)
If nEven(i) > 0 Then
CountEven = CountEven + 1
vEven(CountEven, 1) = AddDigits(i)
vEven(CountEven, 2) = nEven(i)
End If
If nOdd(i) > 0 Then
CountOdd = CountOdd + 1
vOdd(CountOdd, 1) = AddDigits(i)
vOdd(CountOdd, 2) = nOdd(i)
End If
Next i


Add this


'http://excel.tips.net/T002424_Summing_Digits_in_a_Value.html
Function AddDigits(Number As Long) As Integer
Dim i As Integer
Dim Sum As Integer
Dim sNumber As String


sNumber = CStr(Number)
For i = 1 To Len(sNumber)
Sum = Sum + Mid(sNumber, i, 1)
Next
AddDigits = Sum
End Function




Use this macro to extract the data

Sub SumUnique()
Dim col As New Collection
Dim Rc As Range, Rf As Range, r As Range
Dim cel As Range
Dim Srce1 As Range, Srce2 As Range, Tgt As Range
Dim Col1 As Long, Col2 As Long, i As Long


Set Srce1 = Application.InputBox("Select cell in Duplicate column", "Select Source", Type:=8)
Set Srce2 = Application.InputBox("Select cell in Value column", "Select Data", Type:=8)
Col1 = Srce1.Column: Col2 = Srce2.Column


Set Tgt = Application.InputBox("Select target cell", "Select Target", Type:=8)
Set Rc = Srce1.EntireColumn.SpecialCells(xlCellTypeConstants)
Set Rf = Srce1.EntireColumn.SpecialCells(xlCellTypeConstants)
Set r = Union(Rc, Rf)
On Error Resume Next
For Each cel In r
col.Add cel, CStr(cel)
Next
For i = 1 To col.Count
Tgt.Offset(i - 1) = col(i)
Tgt.Offset(i - 1, 1).FormulaR1C1 = "=SUMIF(C" & Col1 & ",RC" & Tgt.Column & ",C[" & Col2 - Tgt.Column - 1 & "])"
Next
Tgt.Offset(col.Count).FormulaR1C1 = "=SUM(C" & Col2 & ")"
Tgt.Offset(col.Count, 1).FormulaR1C1 = "=SUM(R1C:R[-1]C)"
End Sub




If all is OK, then tidy it up!

[mdmackillop]

Revised to

Option Explicit
Option Base 0
Const Drawn As Long = 6
Const MaxF As Long = 59

Dim nEven() As Long
Dim nOdd() As Long
Dim m_recLvl As Long


Sub Odd_And_Even()
Dim vEven As Variant, vOdd As Variant
Dim i As Long, j As Long
Dim CountEven As Long, CountOdd As Long
Dim lRow As Long
Dim MyDist As Variant
With Application
.ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
End With
Columns("A:F").ClearContents
Cells(1, 1).Select


ReDim nEven(0 To Drawn * MaxF)
ReDim nOdd(0 To Drawn * MaxF)


doRecurse 1, 0, 0


With ActiveCell
ReDim vEven(0 To UBound(nEven), 1 To 2)
ReDim vOdd(0 To UBound(nOdd), 1 To 2)


For i = 0 To UBound(nEven)
If nEven(i) > 0 Then
If CountEven < 20 Then vEven(CountEven, 1) = CountEven
vEven(AddDigits(i), 2) = vEven(AddDigits(i), 2) + nEven(i)
CountEven = CountEven + 1
End If
If nOdd(i) > 0 Then
If CountOdd < 20 Then vOdd(CountOdd, 1) = CountOdd
vOdd(AddDigits(i), 2) = vOdd(AddDigits(i), 2) + nOdd(i)
CountOdd = CountOdd + 1
End If
Next i


lRow = ActiveCell.Row


MyDist = Array("Even Sum", "Total Combinations", "Odd Sum", "Total Combinations")
ActiveCell.Offset(0, 0).Resize(UBound(MyDist), 4) = MyDist


ActiveCell.Offset(1, 0).Resize(CountEven, 2) = vEven
ActiveCell.Offset(1, 2).Resize(CountOdd, 2) = vOdd


Cells(Rows.Count, 2).End(xlUp)(2).FormulaR1C1 = "=Sum(R" & lRow + 1 & "C:R[-1]C)"
Cells(Rows.Count, 4).End(xlUp)(2).FormulaR1C1 = "=Sum(R" & lRow + 1 & "C:R[-1]C)"
End With


With Application
.DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
End With
End Sub


Function doRecurse(stInd As Long, EvenSum As Long, OddSum As Long)
Dim i As Long
Dim EvenAdd As Long, OddAdd As Long


m_recLvl = m_recLvl + 1


For i = stInd To MaxF - Drawn + m_recLvl
If m_recLvl < Drawn Then
If i Mod 2 = 0 Then
doRecurse i + 1, EvenSum + i, OddSum
Else
doRecurse i + 1, EvenSum, OddSum + i
End If
Else
If i Mod 2 = 0 Then
EvenAdd = i: OddAdd = 0
Else
OddAdd = i: EvenAdd = 0
End If
nEven(EvenSum + EvenAdd) = nEven(EvenSum + EvenAdd) + 1
nOdd(OddSum + OddAdd) = nOdd(OddSum + OddAdd) + 1
End If
Next i


m_recLvl = m_recLvl - 1
End Function


'http://excel.tips.net/T002424_Summing_Digits_in_a_Value.html
Function AddDigits(Number As Long) As Integer
Dim i As Integer
Dim Sum As Integer
Dim sNumber As String


sNumber = CStr(Number)
For i = 1 To Len(sNumber)
Sum = Sum + Mid(sNumber, i, 1)
Next
AddDigits = Sum
End Function

[PAB]

Hi mdmackillop,

Outstanding, thank you very much :yes .

I was playing around with your first code, unsuccessfully I might add, to try and adapt it to produce exactly the results and format that your revised code produces.
It is exactly what I was after, I can't thank you enough.

I even managed to adapt the code to take it one step further and produce the results for adding those digits together...


sNumber = CStr(1 + Int(Number \ 10 + (Number Mod 10) - 1) Mod 9)

...and changing the <20 to <10, and it worked perfectly.
Thanks again and have a great weekend :beerchug:.