Public MyResult, arr3()
Sub test()
Dim arr(), MyPlayers, MyHeaders
t = Timer 'start timer
With Sheets("Blad1") 'your sheet
MyPlayers = .ListObjects("TBL_Players").DataBodyRange.Value 'table with your players
Application.StatusBar = "creating all combinations"
MyCombinations_L UBound(MyPlayers), 11 'make all possible combinations with 11 players
With .ListObjects("TBL_Teams") 'your table for the teams
.Range.AutoFilter 'reset old filter
MyHeaders = .HeaderRowRange.Value 'read the headerrowrange
ReDim arr(1 To UBound(arr3), 1 To UBound(MyHeaders, 2)) 'make an array with the appropriate size
For i = 1 To UBound(arr) 'loop through the combinations
If i Mod 5000 = 0 Then Application.StatusBar = Format(i, "0,000") & " / " & Format(UBound(arr3), "0,000") 'show progress in the statusbar
s = arr3(i, 1) 'string of 11 players
For j = 1 To Len(s) 'loop through the players
r = Asc(Mid(s, j, 1)) - 64 'number of the player in the players' table
arr(i, 1) = arr3(i, 1) 'combination-string
arr(i, 2) = arr(i, 2) + MyPlayers(r, 2) 'sum of credits
k1 = Application.Match(MyPlayers(r, 3), MyHeaders, 0) 'find column for summing the role
If IsNumeric(k1) Then arr(i, k1) = arr(i, k1) + 1 'crement role with 1
k2 = Application.Match(MyPlayers(r, 3) & "_Players", MyHeaders, 0) 'find column for listing the names
If IsNumeric(k2) Then
arr(i, k2) = arr(i, k2) & IIf(Len(arr(i, k2)) = 0, "", ", ") & MyPlayers(r, 1)
Else
k2 = Application.Match("Non", MyHeaders, 0)
If IsNumeric(k2) Then arr(i, k2) = arr(i, k2) & IIf(Len(arr(i, k2)) = 0, "", ", ") & MyPlayers(r, 1)
End If
Next
Next
If .ListRows.Count Then .DataBodyRange.Delete 'delete old data
.ListRows.Add.Range.Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr 'add new data
With .Range
.AutoFilter 2, "<=100" 'credits <=100
.AutoFilter 4, 1 'WK
.AutoFilter 3, Criteria1:=">=3", Operator:=xlAnd, Criteria2:="<=5" 'Batsman 3-5
.AutoFilter 6, Criteria1:=">=3", Operator:=xlAnd, Criteria2:="<=5" 'Bowler 3-5
.AutoFilter 5, Criteria1:=">=1", Operator:=xlAnd, Criteria2:="<=3" 'All Rounder 1-3
MsgBox Format(.Columns(1).SpecialCells(xlVisible).Count - 1, "0,000") & " teams possible" & vbLf & Format(Timer - t, "0.0\s"), vbInformation, UCase("All Good combinations")
.EntireColumn.AutoFit
End With
End With
End With
Application.StatusBar = ""
End Sub
Sub MyCombinations_L(Aantal, gekozen)
Dim L(), arr(), Arr2(), iCombinations As Long, Last(), Actual()
x = Evaluate("=char(row(65:" & 65 + Aantal - 1 & "))")
L = Application.Transpose(x)
t = Timer
iCombinations = WorksheetFunction.Combin(Aantal, gekozen) 'aantal combinaties
ReDim Actual(1 To gekozen) 'voorbereiden array
ReDim Arr2(iCombinations - 1) 'voorbereiden 2e array, igv. je de waarden wil zien
ReDim arr3(1 To iCombinations, 1 To 1)
For r = 1 To iCombinations 'alle combinaties doorlopen
If r = 1 Then '1e keer = alles op 1,2,3, .... zetten
For k = 1 To gekozen: Actual(k) = k: Next
Else
vorig = Actual
Actual(gekozen) = vorig(gekozen) + 1
If Actual(gekozen) > Aantal Then 'laatste voorbij target !
For k = gekozen - 1 To 1 Step -1 'voorgaande kolommen aflopen
If Actual(k) < Aantal - (gekozen - k) Then 'tot aan die kolom die nog 1 mag opgehoogd worden
Actual(k) = Actual(k) + 1 'die kolom 1 ophogen
For k1 = k + 1 To gekozen 'alle volgende kolommen
Actual(k1) = Actual(k1 - 1) + 1 'gelijk aan de vorige kolom +1
Next
Exit For 'wip uit de loop
End If
Next
End If
End If
For k = 1 To gekozen: Arr2(r - 1) = Arr2(r - 1) & L(Actual(k)): Next 'vul de 2e array met de echte waarden
If VarType(Arr_Exclusives) <> 0 Then
For Each el In Arr_Exclusives
s1 = Replace(Replace(Arr2(r - 1), Mid(el, 1, 1), "", , , vbTextCompare), Mid(el, 2, 1), "", , , vbTextCompare)
If -Len(s1) + Len(Arr2(r - 1)) >= 2 Then Arr2(r - 1) = "~": Exit For
Next
End If
Next
fl = Filter(Arr2, "~", 0, vbTextCompare)
MyResult = fl
If UBound(fl) < 65530 Then
arr3 = Application.Transpose(fl)
Else
ReDim arr3(1 To UBound(fl) + 1, 1 To 1)
For i = 0 To UBound(fl): arr3(i + 1, 1) = fl(i): Next
End If
'MsgBox Timer - t
'r1 = 50000
'MsgBox r1 & " " & arr3(r1, 1) & " " & MyResult(r1 - 1) & vbLf & 10 & " " & arr3(10, 1) & " " & MyResult(9)
End Sub
