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 2, 2019

Hi,

It may be easier way to build a new code in which with the array of ("1", "X", "2") option of selection outcomes for 4 to 14 matches. And the limit for X and 2
For example: if selection could permit following options 
Outcome=4 
Limit for X= 1
Limit for 2= 1
Than combinations will be total 12 in each of the 4 outcome only 1 time will be X =1, and 2=1 in any of the 4 outcomes 
Example combinations...

Book1

A

B

1

11X2

2

112X

3

1X12

4

1X21

5

121X

6

12X1

7

X112

8

X121

9

X211

10

211X

11

21X1

12

2X11

13

14

Sheet2

Thank you in advance

Regards,
Kishan

Kishan · Jul 2, 2019

Kishan said:
Hi,

It may be easier way to build a new code in which with the array of ("1", "X", "2") option of selection outcomes for 4 to 14 matches. And the limit for X and 2
For example: if selection could permit following options 
Outcome=4 
Limit for X= 1
Limit for 2= 1
Than combinations will be total 12 in each of the 4 outcome only 1 time will be X =1, and 2=1 in any of the 4 outcomes

Hi,

I am sure there is no macro that can do what I have requested neither in the goggle search nor in the MrExcel site.

Please any one can help to make it or May I did not find give me a link. 

Thank you in advance

Regards,
Kishan

Eric W · Jul 2, 2019

Try:

Rich (BB code):

Public MyDict

Sub CallRecur()
Dim MyChars As String, MyMaxes As Variant, MaxLen As Long, MyOutput As Range

    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(2, 1, 1)
    MaxLen = 4
    Set MyOutput = Range("C3")
    
    Call Recur(MyChars, MyMaxes, MaxLen, "", 0)
    
    Range(MyOutput, Cells(Rows.Count, MyOutput.Column)).ClearContents
    MyOutput.Resize(MyDict.Count).Value = WorksheetFunction.Transpose(MyDict.keys)
    
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

Set the parameters in red as desired.

Rick Rothstein · Jul 2, 2019

Can you make use of a formula solution? If so, put this formula in cell D5 and copy it down to the row for the last data cell in Column C...

=SUMPRODUCT(--(LEN(A1:A81)-LEN(SUBSTITUTE(A1:A81,"1",""))=--LEFT(C5)),--(LEN(A1:A81)-LEN(SUBSTITUTE(A1:A81,"X",""))=--MID(C5,5,1)),--(LEN(A1:A81)-LEN(SUBSTITUTE(A1:A81,"2",""))=--RIGHT(C5)))

Kishan · Jul 2, 2019

Eric W said:

Try:

Rich (BB code):

Public MyDict

Sub CallRecur()
Dim MyChars As String, MyMaxes As Variant, MaxLen As Long, MyOutput As Range

    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(2, 1, 1)
    MaxLen = 4
    Set MyOutput = Range("C3")
    
    Call Recur(MyChars, MyMaxes, MaxLen, "", 0)
    
    Range(MyOutput, Cells(Rows.Count, MyOutput.Column)).ClearContents
    MyOutput.Resize(MyDict.Count).Value = WorksheetFunction.Transpose(MyDict.keys)
    
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

Set the parameters in red as desired.

Hi Eric, thank you very much for building a new macro I liked the way you build it so I can Set the parameters in red as desired. That is fantastic option. MyMaxes = Array(2, 1, 1) I see also that I did not mentioned 1's only limit for the X's & 2's but you caught the idea. Thank you for your understanding it was bit complicate. 

I tried the macro, which worked perfectly as per giving example post #1, and might it will work also fine with all the parameters with new versions.

After I tried with the version 2000, which I am, running found it stop at the line below

Code:

 MyOutput.Resize(MyDict.Count).Value = WorksheetFunction.Transpose(MyDict.keys)

For some example in the case of following parameters...noticed that may be "WorksheetFunction.Transpose" is not compatible with large data in my version and also 2000 has 65536 max row so need that the code continue writing after 65000 in the next column...to complete the target combinations.

Book1

D

E

F

G

H

5

1

X

2

Combi

Status

6

9

0

5

2.002

Work Fne

7

5

9

0

2.002

Work Fne

8

9

3

2

20.020

Stop at the line above

9

8

3

60.060

Stop at the line above

10

7

3

4

120.120

Stop at the line above

11

5

4

252.252

Stop at the line above

12

5

6

3

168.168

Stop at the line above

13

5

7

2

72.072

Stop at the line above

14

5

8

1

18.018

Stop at the line above

Sheet10

I do appreciate your kind help

Please can you take a look?

Kind Regards,
Kishan

Kishan · Jul 2, 2019

Rick Rothstein said:
Can you make use of a formula solution? If so, put this formula in cell D5 and copy it down to the row for the last data cell in Column C...

=SUMPRODUCT(--(LEN(A1:A81)-LEN(SUBSTITUTE(A1:A81,"1",""))=--LEFT(C5)),--(LEN(A1:A81)-LEN(SUBSTITUTE(A1:A81,"X",""))=--MID(C5,5,1)),--(LEN(A1:A81)-LEN(SUBSTITUTE(A1:A81,"2",""))=--RIGHT(C5)))

Hi Rick, the formula you gave that count the column A as per column C patterns but I wanted a combinations generator, any way thank you for your help 

Kind Regards,
Kishan

Eric W · Jul 2, 2019

I really must stress that there is NEVER any real good reason to actually enumerate all of the combinations. If you get up to the tens of thousands, or hundreds of thousands of combinations, there's no way you can possibly find anything. Nevertheless, here's some code to use multiple columns if needed:

Rich (BB 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


    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(2, 1, 1)
    MaxLen = 4
    Set MyOutput = Range("C3")
    MaxOutputRows = 10000
    
    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
            Range(MyOutput, Cells(Rows.Count, MyOutput.Column)).ClearContents
            MyOutput.Resize(MaxOutputRows).Value = MyTable
            ReDim MyTable(1 To MaxOutputRows, 1 To 1)
            Set MyOutput = MyOutput.Offset(, 1)
            ctr = 1
        End If
    Next i
    If ctr > 1 Then
        Range(MyOutput, Cells(Rows.Count, MyOutput.Column)).ClearContents
        MyOutput.Resize(MaxOutputRows).Value = MyTable
    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 2, 2019

Eric W said:
I really must stress that there is NEVER any real good reason to actually enumerate all of the combinations. If you get up to the tens of thousands, or hundreds of thousands of combinations, there's no way you can possibly find anything. Nevertheless, here's some code to use multiple columns if needed:

I am totally agreed with you it is worthless but creating all may understand it better. I am very grateful to you.

Eric W said:

I really must stress that there is NEVER any real good reason to actually enumerate all of the combinations. If you get up to the tens of thousands, or hundreds of thousands of combinations, there's no way you can possibly find anything. Nevertheless, here's some code to use multiple columns if needed:

Rich (BB 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


    Set MyDict = CreateObject("Scripting.Dictionary")
    
    MyChars = "1X2"
    MyMaxes = Array(2, 1, 1)
    MaxLen = 4
    Set MyOutput = Range("C3")
    MaxOutputRows = 10000
    
    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
            Range(MyOutput, Cells(Rows.Count, MyOutput.Column)).ClearContents
            MyOutput.Resize(MaxOutputRows).Value = MyTable
            ReDim MyTable(1 To MaxOutputRows, 1 To 1)
            Set MyOutput = MyOutput.Offset(, 1)
            ctr = 1
        End If
    Next i
    If ctr > 1 Then
        Range(MyOutput, Cells(Rows.Count, MyOutput.Column)).ClearContents
        MyOutput.Resize(MaxOutputRows).Value = MyTable
    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

Wow! Eric, very much kind of you quick alters a macro to work with my version, it is so flexible and easy-to-use. It is absolutely an extraordinary and powerful solution.

ray:

Macro worked very flawless with all the parameters without any limits.

I heartily appreciate your time and kind help, Thank you

Kind Regards,
Kishan

Eric W · Jul 2, 2019

You're welcome.

Limit numbers for X and 2

Kishan

Well-known Member

Excel Facts

Kishan

Well-known Member

Kishan

Well-known Member

Eric W

MrExcel MVP

Rick Rothstein

MrExcel MVP

Kishan

Well-known Member

Kishan

Well-known Member

Eric W

MrExcel MVP

Kishan

Well-known Member

Eric W

MrExcel MVP

Similar threads

Forum statistics

Share this page

Limit numbers for X and 2

Well-known Member

Excel Facts

Well-known Member

Well-known Member

MrExcel MVP

MrExcel MVP

Well-known Member

Well-known Member

MrExcel MVP

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