vba code to get all combinations and permutations IF they equal a cells

montecarlo2012

Active Member
Joined
Jan 26, 2011
Messages
364
Hello folks
I have been trying to work around this code, I need some hands on here, Please.
I am trying to generate all possible combinations and permutations possible from the set of numbers from 0 to 9 taken four at a time BUT display ONLY the one’s that match the conditions.
The condition that I tried is to have control on odd and even numbers per row and the sum.
The odd and even in this case is only five possible outcomes :
Code:
[TABLE="width: 128"]
 <colgroup><col width="64" span="2" style="width:48pt"> </colgroup><tbody>[TR]
  [TD="class: xl63, width: 64"]odds [/TD]
  [TD="class: xl63, width: 64"]even[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]4[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]1[/TD]
  [TD="class: xl64, align: right"]3[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]2[/TD]
  [TD="class: xl64, align: right"]2[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]3[/TD]
  [TD="class: xl64, align: right"]1[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]4[/TD]
  [TD="class: xl64, align: right"]0[/TD]
[/TR]
</tbody>[/TABLE]
And the total sum will be from 0 to 36, the maximum permutation is 9-9-9-9 so of course 36 is the maximum sum
Also I would like to avoid this two lines

Set rRng = Range("A1", Range("A1").End(xlDown))
rRng.Select: p = 4

because I already know the set of number, and is always 4, but I don’t know how to do it.
The display could start at ("D2")
Thank you.
Code:
Option Explicit
Public sumArr As Long, oddNo As Long, evenNo As Long, oddNoReq As Long, lastRow As Long, _
evenNoReq As Long, minSumValue As Long, maxSumValue As Long, lRow As Long, testRow As Long, minMaxRn As Long
Sub Combinations()
      oddNoReq = Range("B27"): evenNoReq = Range("B26")
      minSumValue = Range("B29"): maxSumValue = Range("B30")
      Dim rRng As Range, p As Integer
      Dim vElements, vresult As Variant
               lRow = 1
               testRow = 1
               Set rRng = Range("A1", Range("A1").End(xlDown))
               rRng.Select: p = 4
               vElements = Application.Index(Application.Transpose(rRng), 1, 0)
               ReDim vresult(1 To p): Columns("C").Resize(, p + 12).Clear
               Call CombinationsNP(vElements, p, vresult, lRow, 1, 1)
      End Sub
      Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
      Dim i As Integer, k As Integer
               For i = iElement To UBound(vElements)
                        vresult(iIndex) = vElements(i)
                                 If iIndex = p Then
                                 For k = LBound(vresult) To UBound(vresult)
                                 If vresult(k) Mod 2 <> 0 Then oddNo = oddNo + 1
                                 If vresult(k) Mod 2 = 0 Then evenNo = evenNo + 1
                                 sumArr = sumArr + vresult(k)
               Next k
                        If oddNo = oddNoReq And evenNo = evenNoReq _
                                 And sumArr >= minSumValue _
                                 And sumArr <= maxSumValue Then
                                 lRow = lRow + 1
                                 Range("S" & lRow) = sumArr
                                 End If
                                 testRow = testRow + 1
                                 Range("k" & testRow).Resize(, p) = vresult
                                 End If
                                 If iIndex <> p Then
                                 Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
                        End If
      
      Next i
End Sub
Thank you for taking time to read this.
 

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
9,289
Try changing this line:

Code:
Call CombinationsNP(vElements, p, vresult, lRow, 1, 1)
to

Code:
Call CombinationsNP(Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9), 4, vresult, lRow, 1, 1)
Here's an alternate version I wrote up with every parameter being passed in the initial CALL:

Code:
Public MyDict

Sub CallPermute()

    Set MyDict = CreateObject("Scripting.Dictionary")
    Call Permute("0123456789", 0, 36, 0, 4, 0, "'", 4, 0, 0)
    Range("D:D").ClearContents
    Range("D2").Resize(MyDict.Count).Value = WorksheetFunction.Transpose(MyDict.keys)
    
End Sub

Sub Permute(ByRef Vals As String, ByRef Pmin As Long, ByRef Pmax As Long, _
            ByVal Psum As Long, ByRef Evens As Long, ByVal Esum As Long, _
            ByVal Rstr As String, ByRef MaxD As Long, ByVal Depth As Long, ByVal Loc As Long)
Dim i As Long, w As Long
            
    If Depth = MaxD Then
        If Psum >= Pmin And Psum <= Pmax And Esum = Evens Then MyDict.Add Rstr, 1
        Exit Sub
    End If
    
    For i = Loc + 1 To Len(Vals)
        w = Mid(Vals, i, 1)
        Call Permute(Vals, Pmin, Pmax, Psum + w, Evens, Esum + IIf(w Mod 2 = 0, 1, 0), Rstr & w, MaxD, Depth + 1, i)
    Next i
            
End Sub
 

montecarlo2012

Active Member
Joined
Jan 26, 2011
Messages
364
Eric W

MrExcel MVP Thank You, So much.
Sir I replace the line you said ►
Call CombinationsNP(Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9), 4, vresult, lRow, 1, 1)◄ I have to change also iRow, then work, but not in the way I was expected. the results derivate from this code are concatenated on D. The part I don't get it is the permutation formula give me 5024 possible outcome, plus combination 240 something like that, but just using common sence, if I want to use the numbers from 0 to 9 in four sets obviously the code must start on ≡ 0,0,0,0 and go all the way up to 9,9,9,9 ≡ so here there are more than 5,040 possible rows.
The results I expect are more or less like this •

Code:
[/COLOR][TABLE="width: 256"]
 <colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>[TR]
  [TD="class: xl63, width: 64"]C[/TD]
  [TD="class: xl63, width: 64"]D[/TD]
  [TD="class: xl63, width: 64"]E[/TD]
  [TD="class: xl63, width: 64"]F[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]0[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]1[/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]0[/TD]
  [TD="class: xl64, align: right"]1[/TD]
  [TD="class: xl64, align: right"]0[/TD]
 [/TR]
 [TR]
  [TD="class: xl64"] [/TD]
  [TD="class: xl64"]UNTIL[/TD]
  [TD="class: xl64"] [/TD]
  [TD="class: xl64"] [/TD]
 [/TR]
 [TR]
  [TD="class: xl64, align: right"]9[/TD]
  [TD="class: xl64, align: right"]9[/TD]
  [TD="class: xl64, align: right"]9[/TD]
  [TD="class: xl64, align: right"]9[/TD]
 [/TR]
 [TR]
  [TD="class: xl64"] [/TD]
  [TD="class: xl64"] [/TD]
  [TD="class: xl64"] [/TD]
  [TD="class: xl64"] [/TD]
[/TR]
</tbody>[/TABLE]
[COLOR=#222222]
and eliminate my constrains.
Thank you Again for your time and kindness

[h=1][/h]
 

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
9,289
It's a little hard to debug your code, since it relies on reading data from the worksheet, which you have not provided. However, I don't know how I missed the fact that you want to allow duplicate values. In my macro, change this line:

Code:
For i = Loc + 1 To Len(Vals)
to

Code:
For i = 1 To Len(Vals)
and you should get the output you want.
 

montecarlo2012

Active Member
Joined
Jan 26, 2011
Messages
364
Thanks Eric W
The code don't have to read anything from the worksheet, it is just to populate the four columns, I will try your lines. and I really accept any code all I want is to see the result under my control statements. Thank you again for your time
 

shg

MrExcel MVP
Joined
May 7, 2008
Messages
21,736
Office Version
2010
Platform
Windows
You want a list of numbers 0000 thru 9999 where each digit has the same parity (odd/even)?

Enter 000 in a cell as text, drag down 10000 rows, and add a formula:

A​
B​
C​
1​
Num
All Odd/Even
2​
0000
TRUE​
B2: =OR(SUM(MOD(MID(A2, {1,2,3,4}, 1), 2)) = {0,4})
3​
0001
FALSE​
4​
0002
TRUE​
5​
0003
FALSE​
6​
0004
TRUE​
7​
0005
FALSE​
8​
0006
TRUE​
9​
0007
FALSE​
10​
0008
TRUE​
11​
0009
FALSE​
12​
0010
FALSE​

Filter col B on True to see those that are:

A​
B​
1​
Num
All Odd/Even
2​
0000
TRUE​
4​
0002
TRUE​
6​
0004
TRUE​
8​
0006
TRUE​
10​
0008
TRUE​
22​
0020
TRUE​
24​
0022
TRUE​
26​
0024
TRUE​
 

montecarlo2012

Active Member
Joined
Jan 26, 2011
Messages
364
Shg. Thanks a lot!
You want a list of numbers 0000 thru 9999 where each digit has the same parity (odd/even)?
No, Sir. I think the best way to describe what I try to do is to say Number Generator with Constraints to Cell Values To Fit My Specific Needs.
It is not alway the same parity; I want to be able to display different parity, and be able to sum the numbers by row, reason why each number are in different column. ("My Journey here is really about VBA")..
I appreciate the time you spent.
 

Forum statistics

Threads
1,089,334
Messages
5,407,655
Members
403,158
Latest member
Limerick2030

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top