Limit numbers for X and 2

Kishan · Jul 1, 2019

Using Excel 2000
Hi,

The code below generate any combinations I use for example Const v& = 4 to 14 where Array is ("1", "X", "2") (3^4=81, and 3^14=4.782.969) so in the given example 3^4= 81 combinations are generated in the column A and column C & D there is a resume how many combinations can be found with example (4-1's=1) with (3-1's & 1-x's =4) 

My query is it possible to limit the numbers of X's & 2's to get only output for those combinations only, like for example 2-1's, 1-X's, 1-2's =12 combinations showed highlighted in blue that can be generated only. So the output only 12 not all the 81 
Code....

Code:

Sub GenerateCombi()
Const v& = 4
     
Dim z, y() As String, q(), u&, g&
Dim a&, b&, c&, d&, p&, MaxRow&
MaxRow = Rows.Count
z = Array("1", "X", "2")
u = UBound(z) + 1
ReDim y(1 To u ^ v, 1 To 1)
     
For a = 1 To v
    For b = 1 To u ^ v Step u ^ a
        For c = b To b + u ^ (a - 1) - 1
            For d = 1 To u
                y(c + u ^ (a - 1) * (d - 1), 1) = _
                    z(d - 1) & y(c + u ^ (a - 1) * (d - 1), 1)
            Next d
        Next c
    Next b
Next a

For a = 1 To u ^ v Step MaxRow
ReDim q(1 To MaxRow, 1 To 1)
    g = 0: p = p + 1
    For b = 1 To MaxRow
        If a + b > u ^ v + 1 Then Exit For
        q(b, 1) = y(a + b - 1, 1)
        g = g + 1
    Next b
Cells(p).Resize(g) = q
Next a

End Sub

Example data...

Book1

A

B

C

D

E

1

1111

2

111X

3

1112

4

11X1

1 | X | 2

Total

5

11XX

4 | 0 | 0

1

6

11X2

3 | 1 | 0

4

7

1121

3 | 0 | 1

4

8

112X

2 | 2 | 0

6

9

1122

2 | 1 | 1

12

10

1X11

2 | 0 | 2

6

11

1X1X

1 | 3 | 0

4

12

1X12

1 | 2 | 1

12

13

1XX1

1 | 1 | 2

12

14

1XXX

1 | 0 | 3

4

15

1XX2

0 | 4 | 0

1

16

1X21

0 | 3 | 1

4

17

1X2X

0 | 2 | 2

6

18

1X22

0 | 1 | 3

4

19

1211

0 | 0 | 4

1

20

121X

21

1212

22

12X1

23

12XX

24

12X2

25

1221

26

122X

27

1222

28

X111

29

X11X

30

X112

31

X1X1

32

X1XX

33

X1X2

34

X121

35

X12X

36

X122

37

XX11

38

XX1X

39

XX12

40

XXX1

41

XXXX

42

XXX2

43

XX21

44

XX2X

45

XX22

46

X211

47

X21X

48

X212

49

X2X1

50

X2XX

51

X2X2

52

X221

53

X22X

54

X222

55

2111

56

211X

57

2112

58

21X1

59

21XX

60

21X2

61

2121

62

212X

63

2122

64

2X11

65

2X1X

66

2X12

67

2XX1

68

2XXX

69

2XX2

70

2X21

71

2X2X

72

2X22

73

2211

74

221X

75

2212

76

22X1

77

22XX

78

22X2

79

2221

80

222X

81

2222

82

83

84

85

Sheet1

Thank you in advance

Regards,
Kishan

Kishan · Jul 5, 2019

Eric W said:
You're welcome.

Hi Eric, thank you so much 

The code is working swift and flawless the I have the max 252.252 combinations which generates by using MyMaxes = Array(5, 4, 5) & MaxLen = 14
setting MaxOutputRows = 65000. This gives result in 4 columns 65.000+65.000+65.000+54.252 =252.252 total output...

I am finding one difficulty for farther analysis needs to put each column combinations separate (11111XXXX22222) using Text-to-Columns in 14 columns and next column living 3 empty next 14 columns this way I split them in 14+3, 14+3, 14+3, 14+3 so far total columns used 68. As my version has 258 columns it is perfect.

But if this would have only the set I want to output no problem but all the time I need to combine with different set so I get different out put in 1 to max 4 columns depending on total combinations setting MaxOutputRows = 65000. 

At this point I require you help once again does it is viable to ask can I get output instead of in the one column in the separate columns. This will avoid for me to use Text-to-Columns and also will be the time saver solution which I did not realize initially. 

Please would you consider my request and if possible to make it for me.

Sorry for the inconvenience

Thank you in advance

Kind Regards,
Kishan

Eric W · Jul 6, 2019

I can include the Text-to-columns as part of the macro. It increases the time the macro takes to run significantly though. I have an old copy of Excel 2000. On my computer, the original macro ran in 68 seconds, the updated version took 160 seconds.

Code:

Public MyDict

Sub CallRecur()
Dim MyChars As String, MyMaxes As Variant, MaxLen As Long, MyOutput As Range
Dim MaxOutputRows As Long, MyTable As Variant, i As Long, MyKeys As Variant, Gap As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(5, 4, 5)
    MaxLen = 14
    Set MyOutput = Range("C1")
    MaxOutputRows = 65000
    Gap = 3
    
    Range(MyOutput, Cells(Rows.Count, Columns.Count)).ClearContents
    
    Call Recur(MyChars, MyMaxes, MaxLen, "", 0)
    
    MyKeys = MyDict.keys
    ctr = 1
    ReDim MyTable(1 To MaxOutputRows, 1 To 1)
    For i = 0 To MyDict.Count - 1
        MyTable(ctr, 1) = MyKeys(i)
        ctr = ctr + 1
        If ctr > MaxOutputRows Then
            MyOutput.Resize(MaxOutputRows).Value = MyTable
            Columns(MyOutput.Column).TextToColumns Destination:=Columns(MyOutput.Column), _
                                                      DataType:=xlDelimited, Comma:=True
            ReDim MyTable(1 To MaxOutputRows, 1 To 1)
            Set MyOutput = MyOutput.Offset(, MaxLen + Gap)
            ctr = 1
        End If
    Next i
    If ctr > 1 Then
        MyOutput.Resize(MaxOutputRows).Value = MyTable
        Columns(MyOutput.Column).TextToColumns Destination:=Columns(MyOutput.Column), _
                                               DataType:=xlDelimited, Comma:=True
    End If
    
End Sub


Sub Recur(ByRef RChars, ByRef RMaxes, ByRef ML, ByVal RStr, ByVal Depth)
Dim i As Long, li As Long

    If ML = Depth Then
        MyDict(RStr) = 1
        Exit Sub
    End If
    
    For i = 1 To Len(RChars)
        li = Len(RStr) - Len(Replace(RStr, Mid(RChars, i, 1), ""))
        If li < RMaxes(i - 1) Then Call Recur(RChars, RMaxes, ML, RStr & Mid(RChars, i, 1) & ",", Depth + 1)
    Next i
    
End Sub

Kishan · Jul 6, 2019

Eric W said:

I can include the Text-to-columns as part of the macro. It increases the time the macro takes to run significantly though. I have an old copy of Excel 2000. On my computer, the original macro ran in 68 seconds, the updated version took 160 seconds.

Code:

Public MyDict

Sub CallRecur()
Dim MyChars As String, MyMaxes As Variant, MaxLen As Long, MyOutput As Range
Dim MaxOutputRows As Long, MyTable As Variant, i As Long, MyKeys As Variant, Gap As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(5, 4, 5)
    MaxLen = 14
    Set MyOutput = Range("C1")
    MaxOutputRows = 65000
    Gap = 3
    
    Range(MyOutput, Cells(Rows.Count, Columns.Count)).ClearContents
    
    Call Recur(MyChars, MyMaxes, MaxLen, "", 0)
    
    MyKeys = MyDict.keys
    ctr = 1
    ReDim MyTable(1 To MaxOutputRows, 1 To 1)
    For i = 0 To MyDict.Count - 1
        MyTable(ctr, 1) = MyKeys(i)
        ctr = ctr + 1
        If ctr > MaxOutputRows Then
            MyOutput.Resize(MaxOutputRows).Value = MyTable
            Columns(MyOutput.Column).TextToColumns Destination:=Columns(MyOutput.Column), _
                                                      DataType:=xlDelimited, Comma:=True
            ReDim MyTable(1 To MaxOutputRows, 1 To 1)
            Set MyOutput = MyOutput.Offset(, MaxLen + Gap)
            ctr = 1
        End If
    Next i
    If ctr > 1 Then
        MyOutput.Resize(MaxOutputRows).Value = MyTable
        Columns(MyOutput.Column).TextToColumns Destination:=Columns(MyOutput.Column), _
                                               DataType:=xlDelimited, Comma:=True
    End If
    
End Sub


Sub Recur(ByRef RChars, ByRef RMaxes, ByRef ML, ByVal RStr, ByVal Depth)
Dim i As Long, li As Long

    If ML = Depth Then
        MyDict(RStr) = 1
        Exit Sub
    End If
    
    For i = 1 To Len(RChars)
        li = Len(RStr) - Len(Replace(RStr, Mid(RChars, i, 1), ""))
        If li < RMaxes(i - 1) Then Call Recur(RChars, RMaxes, ML, RStr & Mid(RChars, i, 1) & ",", Depth + 1)
    Next i
    
End Sub

Hi Eric, thank you so much for adding macro Text-to-Columns it is time saving solution 
I appreciate a lot your time and help you spent to solve my query as I wanted. My other macro works very slowly but this update version macro took only 10 seconds and the previous finished only in 7 second that is really amazing. 

I change the parameter " MyMaxes = Array(13, 0, 1)" & "Set MyOutput = Range("J6")" I have filled header in the first 5 rows as shown below

Book1

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

1

C1

C2

C3

C4

C5

C6

C7

C8

C9

C10

C11

C12

C13

C14

2

C1

C2

C3

C4

C5

C6

C7

C8

C9

C10

C11

C12

C13

C14

3

C1

C2

C3

C4

C5

C6

C7

C8

C9

C10

C11

C12

C13

C14

4

C1

C2

C3

C4

C5

C6

C7

C8

C9

C10

C11

C12

C13

C14

5

C1

C2

C3

C4

C5

C6

C7

C8

C9

C10

C11

C12

C13

C14

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

Sheet4

After I run the macro I am getting result as shown below the range is fixed "J6" it wipe out the headers. Please can you check it is doing with me only?

Book1

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

1

C1

2

C1

3

C1

4

C1

5

C1

6

1

2

7

1

2

1

8

1

2

1

9

1

2

1

10

1

2

1

11

1

2

1

12

1

2

1

13

1

2

1

14

1

2

1

15

1

2

1

16

1

2

1

17

1

2

1

18

1

2

1

19

2

1

20

21

22

23

Sheet5

Thank you in advance

Kind Regards,
Kishan

Eric W · Jul 6, 2019

Try:

Code:

Public MyDict

Sub CallRecur()
Dim MyChars As String, MyMaxes As Variant, MaxLen As Long, MyOutput As Range
Dim MaxOutputRows As Long, MyTable As Variant, i As Long, MyKeys As Variant, Gap As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(5, 4, 5)
    MaxLen = 14
    Set MyOutput = Range("C6")
    MaxOutputRows = 65000
    Gap = 3
    
    Range(MyOutput, Cells(Rows.Count, Columns.Count)).ClearContents
    Set MyOutput = MyOutput.Resize(MaxOutputRows)
    
    Call Recur(MyChars, MyMaxes, MaxLen, "", 0)
    
    MyKeys = MyDict.keys
    ctr = 1
    ReDim MyTable(1 To MaxOutputRows, 1 To 1)
    For i = 0 To MyDict.Count - 1
        MyTable(ctr, 1) = MyKeys(i)
        ctr = ctr + 1
        If ctr > MaxOutputRows Then
            MyOutput.Value = MyTable
            MyOutput.TextToColumns Destination:=MyOutput, DataType:=xlDelimited, Comma:=True
            ReDim MyTable(1 To MaxOutputRows, 1 To 1)
            Set MyOutput = MyOutput.Offset(, MaxLen + Gap)
            ctr = 1
        End If
    Next i
    If ctr > 1 Then
        MyOutput.Value = MyTable
        MyOutput.TextToColumns Destination:=MyOutput, DataType:=xlDelimited, Comma:=True
    End If
    
End Sub


Sub Recur(ByRef RChars, ByRef RMaxes, ByRef ML, ByVal RStr, ByVal Depth)
Dim i As Long, li As Long

    If ML = Depth Then
        MyDict(RStr) = 1
        Exit Sub
    End If
    
    For i = 1 To Len(RChars)
        li = Len(RStr) - Len(Replace(RStr, Mid(RChars, i, 1), ""))
        If li < RMaxes(i - 1) Then Call Recur(RChars, RMaxes, ML, RStr & Mid(RChars, i, 1) & ",", Depth + 1)
    Next i
    
End Sub

Kishan · Jul 7, 2019

Eric W said:
I have an old copy of Excel 2000. On my computer

Hi Eric, I am wondering still you got installed a copy of so old version in your computer; that is great, I am running windows 7 professional and this version works fine. BTW I want to update windows 10. Please can you tell me does this version will work in the windows 10?

Kind Regards,
Kishan

Eric W said:

Try:

Code:

Public MyDict

Sub CallRecur()
Dim MyChars As String, MyMaxes As Variant, MaxLen As Long, MyOutput As Range
Dim MaxOutputRows As Long, MyTable As Variant, i As Long, MyKeys As Variant, Gap As Long

    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(5, 4, 5)
    MaxLen = 14
    Set MyOutput = Range("C6")
    MaxOutputRows = 65000
    Gap = 3
    
    Range(MyOutput, Cells(Rows.Count, Columns.Count)).ClearContents
    Set MyOutput = MyOutput.Resize(MaxOutputRows)
    
    Call Recur(MyChars, MyMaxes, MaxLen, "", 0)
    
    MyKeys = MyDict.keys
    ctr = 1
    ReDim MyTable(1 To MaxOutputRows, 1 To 1)
    For i = 0 To MyDict.Count - 1
        MyTable(ctr, 1) = MyKeys(i)
        ctr = ctr + 1
        If ctr > MaxOutputRows Then
            MyOutput.Value = MyTable
            MyOutput.TextToColumns Destination:=MyOutput, DataType:=xlDelimited, Comma:=True
            ReDim MyTable(1 To MaxOutputRows, 1 To 1)
            Set MyOutput = MyOutput.Offset(, MaxLen + Gap)
            ctr = 1
        End If
    Next i
    If ctr > 1 Then
        MyOutput.Value = MyTable
        MyOutput.TextToColumns Destination:=MyOutput, DataType:=xlDelimited, Comma:=True
    End If
    
End Sub


Sub Recur(ByRef RChars, ByRef RMaxes, ByRef ML, ByVal RStr, ByVal Depth)
Dim i As Long, li As Long

    If ML = Depth Then
        MyDict(RStr) = 1
        Exit Sub
    End If
    
    For i = 1 To Len(RChars)
        li = Len(RStr) - Len(Replace(RStr, Mid(RChars, i, 1), ""))
        If li < RMaxes(i - 1) Then Call Recur(RChars, RMaxes, ML, RStr & Mid(RChars, i, 1) & ",", Depth + 1)
    Next i
    
End Sub

You're a great Eric, I am felling lucky to get an appropriate solution. Thank you for helping me out; I really appreciate your kindness and support.
You have designed a macro so nicely I can say it is a wonderful, better than my request and over my expectations. Macro took just 00:00:09 second to end up. 

Good luck and have a great weekend. 

Thank you

ray: Eric

Kind Regards,
Kishan

Eric W · Jul 7, 2019

My home PC runs Windows 7. It's 10 years old now, but when I bought it, it was high-end. So it surprises me some that the macro takes 3 minutes on my PC, and only 9 seconds on yours. I wouldn't have expected that there would such a big difference, even after 10 years.

As far as running Excel 2000 on Windows 10, I'd expect that it would work, but don't know for sure. It's interesting, I have both Excel 2000 and Excel 2013 installed on the same PC. When installing newer versions of Excel, they typically uninstall the older versions, but they leave Excel 2000 alone.

Anyway, I'm glad I could help, although I'm still skeptical about whether you'll get anything useful from all that data.

shg · Jul 7, 2019

It's 10 years old now, but when I bought it, it was high-end. So it surprises me some that the macro takes 3 minutes on my PC, and only 9 seconds on yours. I wouldn't have expected that there would such a big difference, even after 10 years.

Moore Law certainly predicts that, but it surprises me. CPU clock rates have increased, but I think most performance gains have come through having more cores, which VBA can't avail itself of.

Kishan · Jul 10, 2019

Eric W said:
My home PC runs Windows 7. It's 10 years old now, but when I bought it, it was high-end. So it surprises me some that the macro takes 3 minutes on my PC, and only 9 seconds on yours. I wouldn't have expected that there would such a big difference, even after 10 years.

Hi Eric, I apologies as I change the MyMaxes = Array(7, 3, 4) which makes 120.120 combinations Macro took just 00:00:09 second, but with set-up MyMaxes = Array(5, 4, 5) which makes 252.252 combinations Macro took 00:00:33 second to end up. So sorry for the miss information.

Eric W said:
As far as running Excel 2000 on Windows 10, I'd expect that it would work, but don't know for sure. It's interesting, I have both Excel 2000 and Excel 2013 installed on the same PC. When installing newer versions of Excel, they typically uninstall the older versions, but they leave Excel 2000 alone.

With windows 7 professional I as I have installed excel 2000 I tried to install excel 2007 and it detect immediately version 2000 and ask to remove it. May be the 2013 is has this option to keep both. Thank you for the information.

Eric W said:
Anyway, I'm glad I could help, although I'm still skeptical about whether you'll get anything useful from all that data.

I am very happy with the macro it is very useful for me.

Have a great day 

Kind Regards,
Kishan

Kishan · Jul 10, 2019

shg said:
Moore Law certainly predicts that, but it surprises me. CPU clock rates have increased, but I think most performance gains have come through having more cores, which VBA can't avail itself of.

Hi shg, I have a question Eric macro generate the combinations as per limiting 1, X and 2,

For example setting MyMaxes = Array(10, 0, 4), mean "1's"=10, "X's"=0 and "2's"=4 this gives total 1001 combinations,

If setting MyMaxes = Array(9, 2, 3), mean "1's"=9, "X's"=2 and "2's"=3 this gives total 20020 combinations.

Is there could be any way to calculate different array combinations without using the VBA just with the formula?

Here are some more examples...

1	X	2	TT:Combi
13	0	1	14
12	1	1	182
10	1	3	4.004
10	2	2	6.006
9	3	2	20.020
8	2	4	45.045
8	5	1	18.018
7	0	7	3.432
7	3	4	120.120
6	1	7	24.024

Thank you in advance

Kind Regards,
Kishan

shg · Jul 11, 2019

	A	B	C	D	E
1	1	x	2
2	13	0	1	14	D2: {=FACT(SUM(A2:C2)) / PRODUCT(FACT(A2:C2))}
3	12	1	1	182
4	10	1	2	858
5	10	2	2	6,006
6	9	3	2	20,020

Limit numbers for X and 2

Kishan

Well-known Member

Kishan

Well-known Member

Excel Facts

Eric W

MrExcel MVP

Kishan

Well-known Member

Eric W

MrExcel MVP

Kishan

Well-known Member

Eric W

MrExcel MVP

shg

MrExcel MVP

Kishan

Well-known Member

Kishan

Well-known Member

shg

MrExcel MVP

Similar threads

Forum statistics

Share this page

Limit numbers for X and 2

Well-known Member

Well-known Member

Excel Facts

MrExcel MVP

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

MrExcel MVP

Well-known Member

Well-known Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock