View Full Version : [SOLVED:] Loop through combinations and add only Even & Odd numbers together within each.
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
06-02-2016, 04:54 AM
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
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
06-02-2016, 06:19 AM
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
06-02-2016, 01:26 PM
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
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:.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.