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

31010

[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