VBA Combination/Posibility problem with and "not equal/OR"

[mr.404]

Hello,

I´m trying to improve an given VBA which gives combination for "lottery" where i have 13 slots with 3 different symbols "1, X, 2". They have the given rule that max 6 can get symbol 1, max 6 can get symbol X, and 5 can get symbol 2. I have uploaded the my excel file ready with the filter on slots 1,2, 3 & 4 are given the symbol 1. But here is the part i want to improve. Even if i think the first 4 can get symbol 1, i don´t want a combonination where all of them are 1 at the same time. I want max 3 of 4 can be symbol 1 at the same time. For example:

1,1,1,x,x,x,2,2,2,x,1,2
1,1,2,1,x,x,2,2,2,x,1,2
1,x,1,1,x,x,1,x,2,2,1,1.

This example can never happend

1,1,1,1,x,x,1,x,2,2,1,x


I assume i should have a statement before the for loop where i tell that "j = 1, j = 2, j = 3 & j = 4 can´t be 1 att the same time, max 3 of them can be symbol 1.


Is there someone who can help me, or at least give me a direction of somewhere i can teach.
I appreciate all help.


Here is my vba code

Sub testing()     
Dim aOut, Dict
t = Timer
Set Dict = CreateObject("scripting.dictionary")
For i = 0 To WorksheetFunction.Power(3, 13)
     i1 = i
     s = ""
     ReDim tel(2)
     b = True
     For j = 1 To 13
          Select Case i1 Mod 3
               Case 0: s = s & " 1": tel(0) = tel(0) + 1: If tel(0) > 6 Then b = False: Exit For
               Case 1: s = s & " 2": tel(1) = tel(1) + 1: If tel(1) > 5 Then b = False: Exit For
               Case 2: s = s & " X": tel(2) = tel(2) + 1: If tel(2) > 6 Then b = False: Exit For
          End Select
          i1 = i1 \ 3
     Next
     If b Then Dict(s) = Split(Mid(s, 2))    ': MsgBox "1"
          If i Mod 100000 = 0 Then Application.StatusBar = Format(i, "#,###") & "   " & Dict.Count & "   " & s: DoEvents
     Next
     If Dict.Count Then
          Arr = Dict.keys
          ReDim aOut(1 To UBound(Arr) + 1, 0)
          For i = 1 To Dict.Count
               aOut(i, 0) = Arr(i - 1)
          Next
          With Range("A1")
               If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
                    .CurrentRegion.Offset(1).ClearContents
                    With .Resize(, 13)
                        .Formula = "=""'"" & column()"
                        .Value = .Value
                    End With
                   .Offset(1).Resize(Dict.Count, 13).Value = Application.Index(Dict.items, 0, 0)
                   .CurrentRegion.AutoFilter
              End With
         End If
 MsgBox Dict.Count & vbLf & Timer - t
End Sub

Best regard,
Mr.404

[Paul_Hossler]

I have uploaded the my excel file ready with the filter on slots 1,2, 3 & 4 are given the symbol 1

I don't see the Excel file

[Paul_Hossler]

Taking a shot from scratcn, I tried to modularize it.

Performance doesn't seem to be an issue since work is done in memory

Option Explicit

Const maxLoops As Long = 100
Dim A(1 To 13) As String

Sub drv()
    Dim i As Long, iCounter As Long
    iCounter = maxLoops
    Application.StatusBar = False
    Do While iCounter > 0
        Application.StatusBar = iCounter
        For i = LBound(A) To UBound(A)
            Call PickFrom3(i)
        Next i
        If HowMany("1") <= 6 And _
        HowMany("X") <= 6 And _
        HowMany("2") <= 5 And _
        Max3 Then Exit Do
        iCounter = iCounter - 1
    Loop
    If iCounter = 0 Then
        MsgBox "Too many loops = " & iCounter
    Else
        With ActiveSheet
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(A)).Value = A
        End With
        MsgBox "#1 = " & HowMany("1") & "     #X = " & HowMany("X") & "     #2 = " & HowMany("2")
       Application.StatusBar = False
   End If
End Sub

Function Max3() As Boolean
    Dim i As Long
    Max3 = False
    For i = LBound(A) To UBound(A) - 4
        If A(i) = A(i + 1) And _
            A(i + 1) = A(i + 2) And _
            A(i + 2) = A(i + 3) And _
            A(i + 3) = A(i + 4) Then Exit Function
    Next i
    Max3 = True
End Function

Function HowMany(s As String) As Long
    Dim i As Long, n As Long
    For i = LBound(A) To UBound(A)
        If A(i) = s Then n = n + 1
    Next i
    HowMany = n
End Function


Sub PickFrom3(n As Long)
    Dim R As Double
    R = Rnd
    Select Case R
        Case Is <= 1 / 3
            A(n) = "1"
        Case Is <= 2 / 3
            A(n) = "X"
        Case Else
            A(n) = "2"
    End Select
End Sub

[mr.404]

Hello,

My previous file was to big so I had to reduce the slot from 13 to 8 slots, but the rules are same for the symbols.

I have the the main sheet show how the filters are given, but as I said before I want combination to exclude where the 4 first slots can´t be nr 1 at same time.

[Paul_Hossler]

See if this is better

Option Explicit

Const maxLoops As Long = 100
Dim A(1 To 13) As String

Sub drv()
    Dim i As Long, iCounter As Long, N As Long
    Application.ScreenUpdating = False
    For N = 1 To 7000
    iCounter = maxLoops
    Application.StatusBar = False
    Do While iCounter > 0
         Application.StatusBar = N & " -- " & iCounter
         For i = LBound(A) To UBound(A)
             Call PickFrom3(i)
        Next i
        'max 6 can get symbol 1, max 6 can get symbol X, and 5 can get symbol 2
        If HowMany("1") <= 6 And _
        HowMany("X") <= 6 And _
        HowMany("2") <= 5 And _
        Max3 Then Exit Do
        iCounter = iCounter - 1
     Loop
     If iCounter = 0 Then
        MsgBox "Too many loops = " & iCounter
     Else
        With ActiveSheet
            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(A)).Value = A
        End With
        MsgBox "#1 = " & HowMany("1") & "     #X = " & HowMany("X") & "     #2 = " & HowMany("2")
        Application.StatusBar = False
    End If
    Next N
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

'I want combination to exclude where the 4 first slots can´t be nr 1 att same time.
Function Max3() As Boolean
    Dim i As Long
    Max3 = False
    If A(1) = "1" And A(2) = "1" And A(3) = "1" And A(4) = "1" Then Exit Function
    Max3 = True
End Function


Function HowMany(s As String) As Long
    Dim i As Long, N As Long
    For i = LBound(A) To UBound(A)
        If A(i) = s Then N = N + 1
    Next i
    HowMany = N
End Function


Sub PickFrom3(N As Long)
    Dim R As Double
    R = Rnd
    Select Case R
        Case Is <= 1 / 3
            A(N) = "1"
        Case Is <= 2 / 3
            A(N) = "X"
        Case Else
            A(N) = "2"
    End Select
End Sub

[mr.404]

Thank you Paul,

It´s about what i´m looking for but I wonder, when i filter the first 3 of slots to nr 1 symbol in your latest file, then the 4 slots will only give the choice X and 2.

Is there a way that all the 4 first filter still can show nr 1, or is it impossible for that if i want my rule?

[Paul_Hossler]

IF I'm understand your rule, the first four columns cannot be all be = "1"

So if they are, function Max3() says to try again

'I want combination to exclude where the 4 first slots can´t be nr 1 att same time.
Function Max3() As Boolean
    Dim i As Long
    Max3 = False
    If A(1) = "1" And A(2) = "1" And A(3) = "1" And A(4) = "1" Then Exit Function
    Max3 = True
End Function

Filtering 2, 3, and 4 for ="1" shows that there is no result that has a "1" on column number 1

Capture.JPG

[mr.404]

Hi Paul,

Sry, I misunderstanded.

I got my help.

Thank you for your help.

I appreciate that.!

Best regards,
Mr.404

[Paul_Hossler]

No dups

Try this version

Option Explicit

Const maxLoops As Long = 100
Const numWanted As Long = 1000
Dim A(1 To 13) As String, T() As String
Dim cntT As Long

Sub drv()
    Dim i As Long, iCounter As Long, n As Long
    Dim sAll As String
    Application.ScreenUpdating = False
    cntT = 0
    ReDim T(cntT + 1 To numWanted)
    For n = 1 To numWanted
        iCounter = maxLoops
        Application.StatusBar = False
        Do While iCounter > 0
            Application.StatusBar = n & " -- " & iCounter
            sAll = vbNullString
            For i = LBound(A) To UBound(A)
                Call PickFrom3(i)
                sAll = sAll & A(i)
            Next i
            'max 6 can get symbol 1, max 6 can get symbol X, and 5 can get symbol 2
            If HowMany("1") <= 6 And HowMany("X") <= 6 And HowMany("2") <= 5 And _
           Max3OnesInFirst4 And Not AlreadyUsed(sAll) Then Exit Do
           iCounter = iCounter - 1
      Loop
      If iCounter = 0 Then
          MsgBox "Too many loops = " & iCounter
      Else
          With ActiveSheet
               .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(A)).Value = A
               cntT = cntT + 1
                T(cntT) = sAll
            End With
            Application.StatusBar = False
        End If
    Next n
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub


Function AlreadyUsed(s As String) As Boolean
    Dim n As Long
    n = -1
    On Error Resume Next
    n = Application.WorksheetFunction.Match(s, T, 0)
    On Error GoTo 0
    If n <> -1 Then Stop
    AlreadyUsed = IIf(n = -1, False, True)
End Function


'I want combination to exclude where the 4 first slots can´t be nr 1 att same time.
Function Max3OnesInFirst4() As Boolean
    Dim i As Long
    Max3OnesInFirst4 = False
    If A(1) = "1" And A(2) = "1" And A(3) = "1" And A(4) = "1" Then Exit Function
    Max3OnesInFirst4 = True
End Function


Function HowMany(s As String) As Long
    Dim i As Long, n As Long
    For i = LBound(A) To UBound(A)
        If A(i) = s Then n = n + 1
    Next i
    HowMany = n
End Function


Sub PickFrom3(n As Long)
    Dim R As Double
    R = Rnd
    Select Case R
        Case Is <= 1 / 3
            A(n) = "1"
        Case Is <= 2 / 3
            A(n) = "X"
        Case Else
            A(n) = "2"
    End Select
End Sub

[mr.404]

Ok, thank you

[Paul_Hossler]

Good, let me know if it doesn't work