VB 6 - Combinatorics - Lottery Problem

[gerry43]

Hi, I am new to Visual Basic6 and I am interested in writing a little application for combining 6 numbers from the range of 1....7, or even more, in all possible combinations.
I like to get an result -- Example :
1-2-3-4-5-6
2-3-4-5-6-7
1---3-4-5-6-7
1-2---4-5-6-7
1-2-3---5-6-7
1-2-3-4---6-7
1-2-3-4-5---7
The order of the numbers is not important.
On the internet, I have found two probably useful algorithm - called "Johnson-Trotter Algorithm" or the "Odometer Style Algorithm", useful because I also like to calculate larger combinations (like combinations of 6 numbers out from the range of 1....15). ---
Found at : http://www.xtremevbtalk.com/showthread.php?p=904198

Could anyone help to solve my problem, becaue I am very new to VB (I only wrote a few small/easy applications, whitout the complexity of my current project.
Here, the "Odometer" algorithm:

Option Explicit
'
' Odometer-style Combination generating functions
'    by MathImagics  (Dr Memory) 2004
'
' SetCombination
' NextCombination
' ThisCombination
'
Dim Cwheel() As Long

Public Sub SetCombination(ByVal N As Long, ByVal K As Long, ByVal Combn As String)

   ReDim token(K) As String
   token = Split(Combn, ",")
   
   If UBound(token) <> K - 1 Then Exit Sub
   
   Dim W As Long

   ReDim Cwheel(0 To K)
   
   For W = 1 To K
      Cwheel(W) = Val(token(W - 1))
      If Cwheel(W) <= Cwheel(W - 1) Then Exit Sub  ' invalid combn
      If Cwheel(W) > N Then Exit Sub               ' ditto
      Next
   End Sub
   
Public Function ThisCombination() As String
   '
   ' Current Combination readout
   '
   Dim i As Long, Comb As String
   Comb = Cwheel(1)
   For i = 2 To UBound(Cwheel)
      Comb = Comb & ", " & Cwheel(i)
      Next
   ThisCombination = Comb
   End Function

  
Public Sub NextCombination(ByVal N As Long, ByVal K As Long)
   '  "Combination Odometer"
   '
   '  By MathImagics:  the array Cwheel contains the current
   '                   K items combined, in increasing order.
   '                   Each call to this sub will adjust Cwheel
   '                   so it contains
   '                   the NEXT combination in lex order
   '
   
   Dim i As Long
   Dim j As Long
   i = K
   While Cwheel(i) >= N - K + i
      i = i - 1   ' find rightmost wheel that allows an increment
      If i = 0 Then
         ' wraps around (natch!)
         i = 1
         Cwheel(1) = 0
         End If
      Wend
   Cwheel(i) = Cwheel(i) + 1
   For j = i + 1 To K
      Cwheel(j) = Cwheel(i) + j - i
      Next
   End Sub

I have red this code carefully , several times, but I can´t use it in my project.
I would need your help, for putting that algorithm into a small VB6 program like: 1Command button, -> press it, the algorithm calculates the possible combinations and writes it into "Label1.caption".
That´s all. I would be very grateful for your help (and example code), because sometimes it doesn´t goes on.....
Many thanks in advance, best wishes from Gerry!!!

[vb5prgrmr]

In the most simplest of terms...

Option Explicit

Private Sub Command1_Click()

Dim A() As Variant
A = Array(1, 2, 3, 4, 5, 6, 7)

MakeUniqueCombinationOfSix A

End Sub

Private Sub MakeUniqueCombinationOfSix(AryOfWhat() As Variant)

On Error GoTo MakeUniqueCombinationOfSixError

Dim NCnt1 As Integer, NCnt2 As Integer, NCnt3 As Integer
Dim NCnt4 As Integer, NCnt5 As Integer, NCnt6 As Integer
Dim UpperBoundsOfArray As Integer, LowerBoundsOfArray As Integer

UpperBoundsOfArray = UBound(AryOfWhat)
LowerBoundsOfArray = LBound(AryOfWhat)

For NCnt1 = LowerBoundsOfArray To UpperBoundsOfArray
  For NCnt2 = NCnt1 + 1 To UpperBoundsOfArray
    For NCnt3 = NCnt2 + 1 To UpperBoundsOfArray
      For NCnt4 = NCnt3 + 1 To UpperBoundsOfArray
        For NCnt5 = NCnt4 + 1 To UpperBoundsOfArray
          For NCnt6 = NCnt5 + 1 To UpperBoundsOfArray
            List1.AddItem AryOfWhat(NCnt1) & "," & AryOfWhat(NCnt2) & "," & _
                          AryOfWhat(NCnt3) & "," & AryOfWhat(NCnt4) & "," & _
                          AryOfWhat(NCnt5) & "," & AryOfWhat(NCnt6)
          Next NCnt6
        Next NCnt5
      Next NCnt4
    Next NCnt3
  Next NCnt2
Next NCnt1

Exit Sub
MakeUniqueCombinationOfSixError:

MsgBox "MakeUniqueCombinationOfSix " & Err.Number & ":" & Err.Description

End Sub

However, if you know you are using Integers then change from varient to integer...

Good Luck

[gerry43]

Many Thanks for your code example and your swift reply !
Unfortunately your code will maybee work, if I like to combine number 1,2,3,4,5,6,7 in combinations of 6 numbers.
That´s not real life (my first given example/description of my problem was only made easy).
If I also like to make any combination of 6 numbers out of :
3,12,16,21,31,34,45 (or any other numbers), your code doesn´t work.
Could you please explain your code and add a solution, where I can
choose the needed numbers + an visual output of the calculated combinations ?
eg: I like to choose 6 numbers out of 7 or 8 or 9....(not in order), numbers given.
------6 number combination from 4,6,13,15,20, 21, 29, 36--- or any other---.
(The order of the numbers is not important!)
Many Thanks, Gerry.

[chrispej]

I updated the code a little for VB 2019, variant and list seemed to be retired....

Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
Dim A() As Object = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}

MakeUniqueCombinationOfSix(A)

End Sub

Private Sub MakeUniqueCombinationOfSix(AryOfWhat() As Object)

'On Error GoTo MakeUniqueCombinationOfSixError

Dim NCnt1 As Integer, NCnt2 As Integer, NCnt3 As Integer
Dim NCnt4 As Integer, NCnt5 As Integer, NCnt6 As Integer
Dim UpperBoundsOfArray As Integer, LowerBoundsOfArray As Integer

UpperBoundsOfArray = UBound(AryOfWhat)
LowerBoundsOfArray = LBound(AryOfWhat)

For NCnt1 = LowerBoundsOfArray To UpperBoundsOfArray
For NCnt2 = NCnt1 + 1 To UpperBoundsOfArray
For NCnt3 = NCnt2 + 1 To UpperBoundsOfArray
For NCnt4 = NCnt3 + 1 To UpperBoundsOfArray
For NCnt5 = NCnt4 + 1 To UpperBoundsOfArray
For NCnt6 = NCnt5 + 1 To UpperBoundsOfArray
ListBox2.Items.Add(AryOfWhat(NCnt1) & "," & AryOfWhat(NCnt2) & "," &
AryOfWhat(NCnt3) & "," & AryOfWhat(NCnt4) & "," &
AryOfWhat(NCnt5) & "," & AryOfWhat(NCnt6))
Next NCnt6
Next NCnt5
Next NCnt4
Next NCnt3
Next NCnt2
Next NCnt1

Exit Sub
'If MakeUniqueCombinationOfSixError Then

'MsgBox("MakeUniqueCombinationOfSix " & Err.Number & ":" & Err.Description)
'End If
End Sub

[vb5prgrmr]

Yes it will work, just replace...

A = Array(1, 2, 3, 4, 5, 6, 7)

with

A = Array(3,12,16,21,31,34,45)

or

A = Array(4,6,13,15,20, 21, 29, 36)

or if you want...

A = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "4", "5", "6", "7", "8", "9")

or even...

A = Array(3, 4, 6, 12, 13, 15, 16, 20, 21, 29, 31, 34, 36, 45)

Now, to understand it you need to walk through with F8...

Good Luck

[luvofgreen]

I am new to this site and have been doing a lot of research to find out about combinations and/or permutations. Not sure which way to go except I am leaning towards combinations. I am also not sure if I should hijack this thread, but since you have the best example i am going to try, but will post a new one as well.

VB5prgrmr,
Your code works great as a starting point for me, so this is wonderful, easy to understand and very quick. I have modified it (see below) to give me the 1287 combinations of A thru M in a 8 spot variation or bucket (from your 6). I am trying to write or find code that will find all of the 2 pair combinations given a certain number of items (sometimes repeating) that can be placed into multiple 8 spot arrays.

My question is - if you can help, can this be used if the letters repeated and used in as many unique 8 spot buckets? For instance, I have (purely example, would change each time) AAAAAABBBCCDEEEEFFFFFGGGGGGHIJJJKKLLLLMMM (41 items) and 8 spots to fill randomly. Theoretically I can get the most 5 buckets of variations. 41/8 = 5. Knowing A and G have 6 items, they would not be able to use the last item. So now there is 39. That will leave one opening ((5 buckets * 8 spots) - 39) anywhere in the 5 buckets.

The other stipulation is 1 letter per bucket so not to be repeated, nor will the letter be paired with the same letter in any of the other buckets. i.e.

Bucket 1 AB CD EF GH
Bucket 2 AC DE FG HI
Bucket 3 AB KL GH ID AB is a BAD pair, and GH is also a BAD pair because they are together in bucket 1 already.

I am writing this in Excel if that helps. Any help would be appreciated.


Mod code.............

Private Sub Command1_Click()
 
Dim A() As Variant
 
A = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M")
 
MakeUniqueCombinationOfSix A
 
End Sub
 
Private Sub MakeUniqueCombinationOfSix(AryOfWhat() As Variant)
 
On Error GoTo MakeUniqueCombinationOfSixError
 
Dim NCnt1 As Integer, NCnt2 As Integer, NCnt3 As Integer
Dim NCnt4 As Integer, NCnt5 As Integer, NCnt6 As Integer
Dim NCnt7 As Integer, NCnt8 As Integer
Dim UpperBoundsOfArray As Integer, LowerBoundsOfArray As Integer
 
UpperBoundsOfArray = UBound(AryOfWhat)
LowerBoundsOfArray = LBound(AryOfWhat)
 
For NCnt1 = LowerBoundsOfArray To UpperBoundsOfArray
  For NCnt2 = NCnt1 + 1 To UpperBoundsOfArray
    For NCnt3 = NCnt2 + 1 To UpperBoundsOfArray
      For NCnt4 = NCnt3 + 1 To UpperBoundsOfArray
        For NCnt5 = NCnt4 + 1 To UpperBoundsOfArray
          For NCnt6 = NCnt5 + 1 To UpperBoundsOfArray
            For NCnt7 = NCnt6 + 1 To UpperBoundsOfArray
                For NCnt8 = NCnt7 + 1 To UpperBoundsOfArray
                    List1.AddItem AryOfWhat(NCnt1) & "," & AryOfWhat(NCnt2) & "," & _
                                  AryOfWhat(NCnt3) & "," & AryOfWhat(NCnt4) & "," & _
                                  AryOfWhat(NCnt5) & "," & AryOfWhat(NCnt6) & "," & _
                                  AryOfWhat(NCnt7) & "," & AryOfWhat(NCnt8)
                                  Cnt = Cnt + 1
                Next NCnt8
            Next NCnt7
          Next NCnt6
        Next NCnt5
      Next NCnt4
    Next NCnt3
  Next NCnt2
Next NCnt1
List1.AddItem Cnt
Exit Sub
MakeUniqueCombinationOfSixError:
 
MsgBox "MakeUniqueCombinationOfSix " & Err.Number & ":" & Err.Description
 
End Sub

[vb5prgrmr]

Okay, I think I understand. I believe it would be best to first create your unique two letter combinations...

psudo
for ncnt1 = 1 to length/upperbounds
for ncnt2 = ncnt1 + 1 to length/upperbounds
mystring = mystring & myarray(ncnt1) & myarray(ncnt2) & ","
next ncnt2
next ncnt1

(the above relies upon each element being unique so you will have to create some sort of validation to ensure that the elements passed are unique)

Then split or however you stored the unique combinations of two letters and run through them to create your final result...

myotherarray = split(mystring, ",")
ncnt1..
ncnt2...
ncnt3...
...
ncnt8
...

However, the above will allow for combinations like AB, BC, CD, DE, EF, FG, GH, HI to occur or for combinations like AB, AC, AD, AE, AF, AG, AH, AI to occur. If this is undesirible then you will further need to add validation code.



Good Luck

[luvofgreen]

Thank you for the quick reply! I am at work but will check this out later today or tomorrow.

Crossing my fingers!

[luvofgreen]

My apologies, i am trying to learn coding and I am confused.

As I am reviewing this what is psudo? I am assuming I put this snippet at the end of Line 43 or after Next Ncnt1. And then afterwards I will put validation code after that? OR is this replacing the 8 For Next loops altogether.

Second, is length/upperbounds implying the 8 in my scenario or is it actually a formula? And in that case "length? of what?

psudo
for ncnt1 = 1 to length/upperbounds
for ncnt2 = ncnt1 + 1 to length/upperbounds
mystring = mystring & myarray(ncnt1) & myarray(ncnt2) & ","
next ncnt2
next ncnt1


Thanks for the patience.

[vb5prgrmr]

Pseudo Code = english like statements that represent a process or code to be accomplished not to be confused with actual code.

First part of my pseudo code is taking the unique elements passed in and arrainging the elements into unique pairs. As for the length/upperbounds this is meant to mean for the length of the string passed in ("ABCDEFG") or the upper bounds of an array (MyArray(0) = "A", MyArray(1) = "B").


So here is some more pseudo code for you

Process to make sure that each element of string/array is unique
Process to take those unique elements and create unique pairs
Process to take those unique pairs and create unique combinations



Good Luck