number permutations

i have a list of 18 numbers
i want to generate an array of the combinations of 6 numbers from the list, that sum within a chosen range eg. 160 to 175

any alogrhythm or loop to do this

thnx

I've just had a quick stab at the problem, see what you think.

Code:

---

Option Explicit
Const NUMCOUNT As Long = 18
Const MAXNUM As Long = 50
Private mNumbers() As Long

Private Sub Form_Load()
Dim i As Long, Combination() As Long

    ReDim mNumbers(NUMCOUNT - 1)
    For i = 0 To NUMCOUNT - 1
        mNumbers(i) = Int(Rnd * MAXNUM) + 1
    Next i
   
    'this needs a small array to hold part combinations
    ReDim Combination(5)
    Test mNumbers, 6, 160, 175, Combination
End Sub


Private Sub Test(Numbers() As Long, ByVal Count As Long, ByVal MinTot As Long, ByVal MaxTot As Long, Comb() As Long, Optional ByVal Total As Long, Optional ByVal Index As Long)
Dim T As Long
    If Count Then
        Count = Count - 1
        For Index = Index To UBound(Numbers)
            T = Total + Numbers(Index)
            If T <= MaxTot Then
                Comb(Count) = Numbers(Index)
                Test Numbers, Count, MinTot, MaxTot, Comb, T, Index + 1
            End If
        Next
    Else
        If Total >= MinTot Then 'a new combination has been found (Comb)
            For Index = UBound(Comb) To 0 Step -1
                Debug.Print Comb(Index);
            Next
            Debug.Print
        End If
    End If
End Sub

---

I was thinking that the algorithm could be simplified further if it was in a dedicated module, instead of passing all the variables some could be module level.

I would think that you have to be careful that the original list of 18 contains a set such that 6 selected numbers from that list can satisfy the constraint that their sum falls within the specified range, 160 to 175. It seems too easy to generate a list of 18 numbers that no set of six within the list would qualify.

I suppose one way to ensure a valid list is to prepare the list with a mean of about 28 and a standard deviation of 6. That way you know you will get acceptable numbers to choose from. Milk's specifying a MaxNum of 50 may be getting close to that.

Quote:

---

I would think that you have to be careful that the original list of 18 contains a set such that 6 selected numbers from that list can satisfy the constraint that their sum falls within the specified range, 160 to 175. It seems too easy to generate a list of 18 numbers that no set of six within the list would qualify.

---

that would be fine no matches, no returns problem i had the way i was doing it was way too many returns as i would get same numbers in different orders

milk: your code is much faster than what i was using, thank you

Quote:

---

Originally Posted by westconn1

that would be fine no matches, no returns problem i had the way i was doing it was way too many returns as i would get same numbers in different orders

milk: your code is much faster than what i was using, thank you

---

Most of the time Milk's code never ceases to amaze me. :thumb:

His MaxNum of 50 would expect to yield a mean of 25. 6 x 25 = 150. So you would expect to find enough numbers in a set of 18 that six would sum to between 160 and 175. Still, there is a chance that no set of 6 would, so be careful.

the numbers are pre chosen, the examples i ran earlier, using milks code, produced more than 4k results, from within the 18 chosen numbers i have yet check to see if the list contains duplicates, that is, it does not matter what order the numbers are in within the 6, so i will sort the results to make it easier

having sorted the array comb on checking i found some problems
the seventh column is the variable total
i collected all the results into a 2d array, instead of debug.print

Code:

---

1        20        35        37        37        40        155
1        20        35        37        37        40        140
1        20        35        37        37        40        151
1        20        35        37        37        40        144
1        20        35        37        37        40        145
1        20        35        37        37        40        142
1        20        35        37        37        37        134
1        20        35        37        37        37        130
1        20        35        36        37        37        148
1        20        35        36        37        37        132
1        20        35        36        37        37        137
1        20        35        37        37        37        133

---

as you can see from the small excerpt above the i get the same combinations more than once, but also numbers duplicated, which is probably harder to fix and also many do not fall into the summed range

Hi Westconn, I saw you post and thought hmm yes I did write it quite quickly, but on testing I can't get the errors you are seeing so I think it might be how you are adding to the 2D array. (I tested to make sure the six numbers always added up to the stored total and were in the given range)

If the source set of 18 has no repeating numbers then I'm pretty sure no repeating combinations can be found. If there are any duplicates then for every duplicate, duplicate combinations will be found.

Because the algorithm works with the source set in order, if the source set was sorted ascending/descending then the combinations will also be generated in order, making duplicates easy to weed out.

Rather than using a 2D array it might be worth trying a big 1D array instead, it should improve the speed moderately.

As a side note to what Code Doc is saying the algo should return very quickly if no valid combinations can be generated (i.e. the range is to high/low for the source set)

Edit: Having said the above I'm hoping others might have a pop at this problem too, I'm sure there are possibly better ways to do this.

the 18 numbers had no duplicates, but were not sorted, although i thought afterwards sorted might have been better, then may not have need to sort all the returns

this is the only part of the code i changed to add to the 2d array

vb Code:

If Total >= MinTot Then 'a new combination has been found (Comb)
            QuickSort Comb, LBound(Comb), UBound(Comb)
            For Index = UBound(Comb) To 0 Step -1
'                Debug.Print Comb(Index);
                 retarr(Index + 1, UBound(retarr, 2)) = Comb(Index)
            Next
            retarr(7, UBound(retarr, 2)) = Total
            ReDim Preserve retarr(1 To 7, 1 To UBound(retarr, 2) + 1)
        End If

so it just passed the 1d array comb to a quicksort, then loops into a row of the 2d array, as you were doing then adds total to the last element, then a new row ready for the next

the source set i used generated 4084 returns
5 25 40 19 3 8 22 7 18 11 12 9 36 20 1 37 35 34

i sorted the source set this time so will check the results later

Here is the same algo as before adjusted to return a 2D array. Tested and working.

Code:

---

Option Explicit

Public Function FindPermutations(Numbers() As Long, ByVal SetSize As Long, ByVal MinTot As Long, ByVal MaxTot As Long) As Long()
'Returns a 2D array containing the sets of numbers that total within the passed range
Dim Comb() As Long, ct As Long
    ReDim Comb(SetSize - 1)
    FindPermutationsRecurse Numbers, FindPermutations, ct, SetSize, MinTot, MaxTot, Comb
    If ct Then
        ReDim Preserve FindPermutations(SetSize - 1, ct - 1)
    Else
        ReDim FindPermutations(SetSize - 1, -1 To -1)
    End If
End Function

Private Sub FindPermutationsRecurse(Numbers() As Long, Results() As Long, FoundCt As Long, ByVal Count As Long, ByVal MinTot As Long, ByVal MaxTot As Long, Comb() As Long, Optional ByVal Total As Long, Optional ByVal Index As Long)
Dim T As Long
    If Count Then
        Count = Count - 1
        For Index = Index To UBound(Numbers)
            T = Total + Numbers(Index)
            If T <= MaxTot Then
                Comb(Count) = Numbers(Index)
                FindPermutationsRecurse Numbers, Results, FoundCt, Count, MinTot, MaxTot, Comb, T, Index + 1
            End If
        Next
    Else
        If Total >= MinTot Then 'a new combination has been found
            T = UBound(Comb)
            If (FoundCt And 255) = 0 Then ReDim Preserve Results(T, FoundCt + 255)
            For Index = UBound(Comb) To 0 Step -1
                Results(T - Index, FoundCt) = Comb(Index)
            Next
            FoundCt = FoundCt + 1
        End If
    End If
End Sub

---

Have just found this thread and as it would help me in completing my task of predicting next set of lotto numbers I would like to resurrect this thread.
Have used to code above and modified it to clear arrays etc and output info to a datagridview, also calculate Linewidth, Number Odd, Number Even Number Low and Number High. Have modified it to be used with various Lotto where picks are 5, 6 or 7 balls. However I cannot fathom out why I cannot filter out picks that do no match a criteria of Equal to Number of Odd Numbers just after testing the Total value of the picks.

I add


Private Sub FindPermutationsRecurse(ByRef Numbers As Integer(), _
ByRef retarr As Integer(,), _
ByRef FoundCt As Integer, _
ByVal Count As Integer, _
ByRef MinTot As Integer, _
ByRef MaxTot As Integer, _
Comb As Integer(), _
Total As Integer, _
Odd As Integer, _
Index As Integer)


Dim T As Long
Dim O As Long

Dim idx As Integer = 0
Dim SwapArray(5) As Long

Try

If Count Then

Count -= 1

For Index = Index To UBound(Numbers)

T = Total + Numbers(Index)

If Numbers(Index) Mod 2 <> 0 Then
O = Odd + 1
End If

If T <= MaxTot Then
Comb(Count) = Numbers(Index)
FindPermutationsRecurse(Numbers, retarr, FoundCt, Count, MinTot, MaxTot, Comb, T, O, Index + 1)
End If
Next

Else

If Total >= MinTot Then 'a new combination has been found (Comb)

If Odd = NumberOdd Then

Array.Copy(Comb, SwapArray, 6)
Array.Sort(SwapArray)

For x = 0 To 5
retarr(FoundCt, x) = SwapArray(x)
Next

retarr(FoundCt, 6) = Total

FoundCt += 1

End If

End If

End If

Catch ex As Exception
MsgBox(ex.Message)
End Try

End Sub


but it does not want to work. Am I missing something so glaring obvious


Hoping for some help

Cheers

1-welcome to the forum
2-Don't steal someone else's threat, start your own and REFERENCE it
3-Always use code tags to differentiate your code from your comments
4-westconn1 is still active in this form, even if this thread WAS started 6 years ago....just wait and he may come on line and help you.

Sammi

Threat?

Quote:

---

Originally Posted by Gruff

Threat?

---

Thread + Post = Threat :)

OK Ok....guess it was a Freudian! Gettin' toward quittin' time...and just had just finished a 4 mile run at lunch...gimme some slack! :rolleyes:

*Grin*

Quote:

---

4-westconn1 is still active in this form, even if this thread WAS started 6 years ago....just wait and he may come on line and help you.

---

i remember the thread, but i do not remember what i ever did with the code (if anything) in the end
i am not sure that i would have any advantage over anyone else to resolve the current problem, as would have to relearn it all anyway

Quote:

---

and just had just finished a 4 mile run at lunch

---

rather you than me

Quote:

---

rather you than me

---

At age 65, training for my first 1/2 Marathon. Part way there. :(