Help for a Newbie

[Alanesque]

Disclaimer: Please forgive my EXTREME newbie-ness. I dont even know how to use this forum, and i MINIMAL knowledge of Excel. I hunt and peck away through videos, etc to accomplish tasks, slowly:

This is my variation on the "ListthemAll" code. My project is a little different but your code works to a point. I changed some numbers to fit my project . The problem is , I cant have repeating numbers, and i dont know how to adjust it for that. Can you help?



Sub ListThemAll()
TC = 1
TR = 1
Ctr = 1
MaxRows = Rows.Count
EndCell = 7059052
Application.ScreenUpdating = False
For a = 1 To 29
For b = 1 To 6
For c = 2 To 14
For d = 3 To 17
For e = 4 To 21
For f = 5 To 37
Application.StatusBar = Ctr & " on way to " & EndCell
Cells(TR, TC).Value = a & "-" & b & "-" & c & "-" & d & "-" & e & "-" & f
Ctr = Ctr + 1
If Ctr Mod 25000 = 0 Then
Cells(TR - 20, TC).Select
Application.ScreenUpdating = True
ThisWorkbook.Save
Application.ScreenUpdating = False
End If

TR = TR + 1
If TR = MaxRows Then
TR = 1
TC = TC + 1
End If
Next f
Next e
Next d
Next c
Next b
Next a
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub


BTW...the FIRST occurence of the repeated number HAS to stay, and IN the place it occured. Which is always the FIRST slot

 

[StephenCrump]

Welcome to the Forum!

My project is a little different ....

Your starting code comes from a post about lottery numbers, and EndCell = 7059052 suggests a 6/44 lottery?

But what is your project? It's a little hard for us to help if we don't know what you're trying to do.

The problem is , I cant have repeating numbers, and i dont know how to adjust it for that.

BTW...the FIRST occurence of the repeated number HAS to stay, and IN the place it occured. Which is always the FIRST slot

It's not at all clear what you mean by this?

If you just need code to enumerate Combin(44,6), or some subset, this can be written far more efficiently than the code you're starting with.

 

[Alanesque]

I really dont even know the lingo enough to explain but i will try:

This was the original code that i got from this forum:



Sub ListThemAll()
TC = 1
TR = 1
Ctr = 1
MaxRows = Rows.Count
EndCell = 7059052
Application.ScreenUpdating = False
For a = 1 To 39
For b = (a + 1) To 40
For c = (b + 1) To 41
For d = (c + 1) To 42
For e = (d + 1) To 43
For f = (e + 1) To 44
Application.StatusBar = Ctr & " on way to " & EndCell
Cells(TR, TC).Value = a & "-" & b & "-" & c & "-" & d & "-" & e & "-" & f
Ctr = Ctr + 1
If Ctr Mod 25000 = 0 Then
Cells(TR - 20, TC).Select
Application.ScreenUpdating = True
ThisWorkbook.Save
Application.ScreenUpdating = False
End If
TR = TR + 1
If TR = MaxRows Then
TR = 1
TC = TC + 1
End If
Next f
Next e
Next d
Next c
Next b
Next a
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub

I made the changes i did because of this :

Slot 1	Slot 2	Slot 3	Slot 4	Slot 5	Slot 6
1​	1​	2​	3​	4​	5​
2​	2​	3​	4​	5​	6​
3​	3​	4​	5​	6​	7​
4​	4​	5​	6​	7​	8​
5​	5​	6​	7​	8​	9​
6​	6​	7​	8​	9​	10​
7​		8​	9​	10​	11​
8​		9​	10​	11​	12​
9​		10​	11​	12​	13​
10​		11​	12​	13​	14​
11​		12​	13​	14​	15​
12​		13​	14​	15​	16​
13​		14​	15​	16​	17​
14​			16​	17​	18​
15​			17​	18​	19​
16​				19​	20​
17​				20​	21​
18​				21​	22​
19​					23​
20​					24​
21​					25​
22​					26​
23​					27​
24​					28​
25​					29​
26​					30​
27​					31​
28​					32​
29​					33​
					34​
					35​
					36​
					37​

123456 is good....
112345 is bad
213456 is good
223456 is bad.
I cant have repeaters. AFTER the number has appeared ONCE, it cant appear again in the set.
its LIKE powerball with the special ball (which would be in slot one in this case. HOWEVER, with powerball the number CAN appear again. With my project, it cannot.
i hope that helps.

 

[Alanesque]

this is what i am getting with my macro. This ISNT for lottery. Its for Fantasy sports. Where each number represents a player in a contest.

1-1-2-3-4-5	2-4-2-13-9-5
1-1-2-3-4-6	2-4-2-13-9-6
1-1-2-3-4-7	2-4-2-13-9-7
1-1-2-3-4-8	2-4-2-13-9-8
1-1-2-3-4-9	2-4-2-13-9-9
1-1-2-3-4-10	2-4-2-13-9-10
1-1-2-3-4-11	2-4-2-13-9-11

 

[Alanesque]

The first slot contains "The Captain"...so the Captain CANT also appear in among the "Crew"

 

[StephenCrump]

The code below should do what you're after. Here's the input/output for a much smaller example.

	A	B	C	D	E	F	G	H	I	J	K
1	Input						Output	1	2	3	4
2	1	2	3	4				1	2	3	5
3	3	4	7	6				1	2	3	6
4								1	2	4	5
5								1	2	4	6
6								1	2	5	4
7								1	2	5	6
8								1	2	6	4
9								1	2	6	5
10								1	2	7	4
11								1	2	7	5
12								1	2	7	6
13								1	3	4	5
14								1	3	4	6
15								1	3	5	4
16								1	3	5	6
17								1	3	6	4
18								1	3	6	5
19								1	3	7	4
20								1	3	7	5
21								1	3	7	6
22								1	4	3	5
23								1	4	3	6
24								1	4	5	6
25								1	4	6	5
26								1	4	7	5
27								1	4	7	6
28								2	3	4	5
29								2	3	4	6
30								2	3	5	4
31								2	3	5	6
32								2	3	6	4
33								2	3	6	5
34								2	3	7	4
35								2	3	7	5
36								2	3	7	6
37								2	4	3	5
38								2	4	3	6
39								2	4	5	6
40								2	4	6	5
41								2	4	7	5
42								2	4	7	6
43								3	2	4	5
44								3	2	4	6
45								3	2	5	4
46								3	2	5	6
47								3	2	6	4
48								3	2	6	5
49								3	2	7	4
50								3	2	7	5
51								3	2	7	6
52								3	4	5	6
53								3	4	6	5
54								3	4	7	5
55								3	4	7	6
Sheet1

The code should also accommodate your bigger example. On my machine it takes under a minute to print all 11.2 million possibilities.

Sub Test()
    
    Dim i As Long, NoRows As Long
    
    Application.ScreenUpdating = False
    counter = 1
    NoRows = 1
    NoCols = 0
    MaxRows = 1000000
    Set r = Range("H1")     'Output cell, change as appropriate
    With Range("A2:D3")     'Input cells, edit as appopriate
        N = .Columns.count
        ReDim lMin(1 To N)
        ReDim lMax(1 To N)
        For i = 1 To N
            lMin(i) = .Cells(1, i).Value
            lMax(i) = .Cells(2, i).Value
            NoRows = NoRows * (lMax(i) - lMin(i) + 1)
        Next i
    End With
    ReDim lPermutations(1 To NoRows + 1, 1 To N)
        
    On Error Resume Next
    Range("MyResults").ClearContents
    On Error GoTo 0
    
    Call GetPermutations(1)
        
    If counter > 1 Then
        r.Offset(, (N + 1) * NoCols).Resize(counter - 1, N).Value = lPermutations
        NoCols = NoCols + 1
    End If
    
    If NoCols > 1 Then
        r.Resize(MaxRows, NoCols * (N + 1)).Name = "MyResults"
    Else
        r.Resize(counter - 1, N).Name = "MyResults"
    End If
    Application.ScreenUpdating = True
        
End Sub
Sub GetPermutations(k As Long)
    
    Dim i As Long, j As Long
    Dim bDup As Boolean
        
    For i = lMin(k) To lMax(k)
        bDup = False
        For j = k - 1 To 1 Step -1
            If i = lPermutations(counter, j) Then
                bDup = True
                Exit For
            End If
        Next j
        If Not bDup Then
            lPermutations(counter, k) = i
            If k = N Then
                counter = counter + 1
                If counter > MaxRows Then
                    r.Offset(, (N + 1) * NoCols).Resize(MaxRows, N).Value = lPermutations
                    NoCols = NoCols + 1
                    counter = 1
                    For j = 1 To k - 1
                        lPermutations(counter, j) = lPermutations(MaxRows, j)
                    Next j
                Else
                    For j = 1 To k - 1
                        lPermutations(counter, j) = lPermutations(counter - 1, j)
                    Next j
                End If
            Else
                Call GetPermutations(k + 1)
            End If
        End If
    Next i
                        
End Sub

 

[Alanesque]

The code below should do what you're after. Here's the input/output for a much smaller example.

	A	B	C	D	E	F	G	H	I	J	K
1	Input						Output	1	2	3	4
2	1	2	3	4				1	2	3	5
3	3	4	7	6				1	2	3	6
4								1	2	4	5
5								1	2	4	6
6								1	2	5	4
7								1	2	5	6
8								1	2	6	4
9								1	2	6	5
10								1	2	7	4
11								1	2	7	5
12								1	2	7	6
13								1	3	4	5
14								1	3	4	6
15								1	3	5	4
16								1	3	5	6
17								1	3	6	4
18								1	3	6	5
19								1	3	7	4
20								1	3	7	5
21								1	3	7	6
22								1	4	3	5
23								1	4	3	6
24								1	4	5	6
25								1	4	6	5
26								1	4	7	5
27								1	4	7	6
28								2	3	4	5
29								2	3	4	6
30								2	3	5	4
31								2	3	5	6
32								2	3	6	4
33								2	3	6	5
34								2	3	7	4
35								2	3	7	5
36								2	3	7	6
37								2	4	3	5
38								2	4	3	6
39								2	4	5	6
40								2	4	6	5
41								2	4	7	5
42								2	4	7	6
43								3	2	4	5
44								3	2	4	6
45								3	2	5	4
46								3	2	5	6
47								3	2	6	4
48								3	2	6	5
49								3	2	7	4
50								3	2	7	5
51								3	2	7	6
52								3	4	5	6
53								3	4	6	5
54								3	4	7	5
55								3	4	7	6
Sheet1

The code should also accommodate your bigger example. On my machine it takes under a minute to print all 11.2 million possibilities.

Sub Test()
   
    Dim i As Long, NoRows As Long
   
    Application.ScreenUpdating = False
    counter = 1
    NoRows = 1
    NoCols = 0
    MaxRows = 1000000
    Set r = Range("H1")     'Output cell, change as appropriate
    With Range("A2:D3")     'Input cells, edit as appopriate
        N = .Columns.count
        ReDim lMin(1 To N)
        ReDim lMax(1 To N)
        For i = 1 To N
            lMin(i) = .Cells(1, i).Value
            lMax(i) = .Cells(2, i).Value
            NoRows = NoRows * (lMax(i) - lMin(i) + 1)
        Next i
    End With
    ReDim lPermutations(1 To NoRows + 1, 1 To N)
       
    On Error Resume Next
    Range("MyResults").ClearContents
    On Error GoTo 0
   
    Call GetPermutations(1)
       
    If counter > 1 Then
        r.Offset(, (N + 1) * NoCols).Resize(counter - 1, N).Value = lPermutations
        NoCols = NoCols + 1
    End If
   
    If NoCols > 1 Then
        r.Resize(MaxRows, NoCols * (N + 1)).Name = "MyResults"
    Else
        r.Resize(counter - 1, N).Name = "MyResults"
    End If
    Application.ScreenUpdating = True
       
End Sub
Sub GetPermutations(k As Long)
   
    Dim i As Long, j As Long
    Dim bDup As Boolean
       
    For i = lMin(k) To lMax(k)
        bDup = False
        For j = k - 1 To 1 Step -1
            If i = lPermutations(counter, j) Then
                bDup = True
                Exit For
            End If
        Next j
        If Not bDup Then
            lPermutations(counter, k) = i
            If k = N Then
                counter = counter + 1
                If counter > MaxRows Then
                    r.Offset(, (N + 1) * NoCols).Resize(MaxRows, N).Value = lPermutations
                    NoCols = NoCols + 1
                    counter = 1
                    For j = 1 To k - 1
                        lPermutations(counter, j) = lPermutations(MaxRows, j)
                    Next j
                Else
                    For j = 1 To k - 1
                        lPermutations(counter, j) = lPermutations(counter - 1, j)
                    Next j
                End If
            Else
                Call GetPermutations(k + 1)
            End If
        End If
    Next i
                       
End Sub

Thank you VERY MUCH SIR!