macro req

R

rasikgowda

New Member
Joined
Apr 8, 2022
Messages
3
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
in an Excel spreadsheet. Create an excel where there are 22 players list and create all the possible combinations
for 11 players team. The conditions are as below :- Create your team by picking 11 players as per the following
combinations (C1,C2,C3...) within a budget of 100 credits.

Step 2: Create your Team
Select players for your team from all 4 of the categories mentioned below: WK - Wicket-keeper (1)
BAT - Batsmen( min 3 & max 5) BWL - Bowlers( min 3 & max 5) AR - All-rounders( min 1 & max 3)

So there are 7 combinations for the team which could be created.

Once all the combinations are created.. we need to check which teams credits sum to 100 credits.
The input will be 22 players and the credits required and the points earned so far. After that from
the shortlisted teams create an combinations of Captain & vice captain for each team. This will be
separate sheet where I will enter the 11 players team. The combinations of Captain and vice Captain
should output in next excel.
 

Attachments

  • Excel.jpg
    Excel.jpg
    163.9 KB · Views: 74
Sort by date Sort by votes
a nice one, approx. 700K combinations possible, a part of them with sum credits (what, <,=,>) 100.
And then the other restrictions.
An example with the XL2BB-tool is better then your image.
Is this homework for school ??
Is VBA allowed ?
Is it for excel 2016 or 365 ?
 
Upvote 0
Excel sheet.xlsx
ABCDEFG
1Team ATeam B
2Players NameCreditsRolePlayers NameCreditsRole
31Faf du Plessis10BatsmanVenkatesh Iyer 9All Rounder
42Anuj Rawat 8BatsmanAjinkya Rahane8,5Batsman
53Virat Kohli10,5BatsmanNitish Rana 9Batsman
64 Dinesh Karthik 8,5wk BatsmanShreyas Iyer 9,5Batsman
75Sherfane Rutherford 8BatsmanSam Billings 8,5wk Batsman
86Wanindu Hasaranga 9All RounderAndre Russell 10All Rounder
97David Willey 8,5BowlerSheldon Jackson 8wk Batsman
108Harshal Patel 9BowlerSunil Narine 9,5All Rounder
119Shahbaz Ahmed 8,5All RounderShivam Mavi 8,5Bowler
1210Akash Deep 8BowlerUmesh Yadav 8,5Bowler
1311Mohammed Siraj 8,5BowlerVarun Chakravarthy8,5Bowler
Sheet1
 
Upvote 0
rasikgowda.xlsmi had somewhere an old macro for those combinations
VBA Code: 
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
 
Upvote 0
BSALV said:
rasikgowda.xlsmi had somewhere an old macro for those combinations
VBA Code: 
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
Click to expand...
Hi everyone, am new to this forum, thanks for providing the code but am getting below error, and its showing error at private of 1st line , pls help
1662925206219.png

1662925258178.png
 
Upvote 0
Could you please provide the excel file and its Macro's. Thanks in advance.
 
Upvote 0
Hi BASLV, Hope you are doing well, need your inputs and help.
Thanks.
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Build an fantasy sports team combination generator
Replies
3
Views
6K
BSALV
BSALV
P
  • Solved
Calculating shortest to longest distances between Zip Codes (using latitude and longitude)
2 3
Replies
25
Views
3K
pawcoyote
P
W
  • Question Question
Personnel Roster using Macro's
Replies
0
Views
342
womeclr
W
M
  • Question Question
#REF Error in LAMBDA function when inserting rows
Replies
0
Views
1K
macfuller
M
Emerlin
  • Solved
Formula needed to filter and sort data from range - Excel 2016.
2
Replies
10
Views
456
Peter_SSs
Peter_SSs

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top