Home » excel » excel – Select items from list

excel – Select items from list

Posted by: admin March 9, 2020 Leave a comment

Questions:

Problem:

There are N Soccer players in the format below and the sheet will spit out every 11-player combination of the players.

Each 11-player line-up must follow the constraints below.

It should be able to select players as ‘core’ meaning that they will appear in 100% of the output line-ups.

Input:

  A               B       C        D                 E
Name          Position  Team     Salary     Core Player? 1="Yes",0="No"
Darron Gibson   M        EVE    6500000              0
Riyad Mahrez    M        LEI    11700000             0
Andrej Kramaric F        LEI    6900000              0
Sadio Mané      M        SOT    12600000             0
Victor Anichebe F        WBA    5300000              1
Serge Gnabry    M        WBA    6300000              0
Dimitri Payet   M        WHM    13500000             0
Juan Mata       M        MUN    10700000             0
  .
  .
  .so on there is list of players

Constraints for each team:

Maximum Salary  100000000   Allowed per team

'These are the maximum and minimum no. of players for a position per team   
Position    Min   Max   
  G          1    1
  D          3    4
  M          3    5
  F          1    3

'there can be maximum no. of four players from a single team
' e.g. MUN (manchester united)          
Maximum Number of Players from one team     4   
Total number of players     11            'Total no. of players per team

Output Example:

    Player 1    Player 2    Player 3    Player 4    Player 5    Player 6    Player 7    Player 8    Player 9    Player 10   Player 11
    Player 1    Player 2    Player 3    Player 4    Player 5    Player 6    Player 7    Player 8    Player 9    Player 10   Player 12
    Player 1    Player 2    Player 3    Player 4    Player 5    Player 6    Player 7    Player 8    Player 9    Player 10   Player 13
    Player 1    Player 2    Player 3    Player 4    Player 5    Player 6    Player 7    Player 8    Player 9    Player 10   Player 14
.
.
.
.

'Update: Players can be repeated in another teams but no match for full line up is allowed 

 Like this is not allowed

Player 1    Player 2    Player 3    Player 4    Player 5    Player 6    Player 7    Player 8    Player 9    Player 10   Player 11
Player 1    Player 3    Player 2    Player 5    Player 4    Player 6    Player 7    Player 8    Player 9    Player 10   Player 11

Attached File

My idea was to first place them and then check for constraints as the order in which they are selected doesn’t matters and make them correct until the conditions are satisfied but this getting complex on every stage.

What I’ve tried (Not complete):

Option Explicit
Sub Teams()
Dim wi, wo, wt, ws As Worksheet
Dim i, j, l, d, m, ct, c, a, b, r As Long
Dim TotalG, TotalD, TotalM, TotalF, TotalSal, Sal, SalLeft, MaxTeam As Long
Dim Team, Pos, Name As String
Dim FinalRowI, FinalRowO As Long
Dim Drng As Range
Dim Mrng As Range

Set wi = Sheet1
Set wo = Sheet2
Set wt = Sheet3
Set ws = Sheet4

FinalRowI = wi.Range("A900000").End(xlUp).Row

TotalG = 0
TotalD = 0
TotalM = 0
TotalF = 0
Sal = 0
SalLeft = 0
TotalSal = wi.Range("H14").Value

    For i = 2 To FinalRowI

        Name = Trim(wi.Range("A" & i).Text)
        Pos = Trim(wi.Range("B" & i).Text)
        Team = Trim(wi.Range("C" & i).Text)
        Sal = wi.Range("D" & i).Value

        Select Case Pos

        Case "G"
            TotalG = TotalG + 1

        Case "D"
            TotalD = TotalD + 1

        Case "M"
            TotalM = TotalM + 1

        Case "F"
            TotalF = TotalF + 1

        Case Else
        End Select
    Next i

    MaxTeam = (WorksheetFunction.Min(CInt(TotalD), CInt(TotalM))) / 3

    MaxTeam = (WorksheetFunction.Min(CInt(MaxTeam), CInt(TotalG), CInt(TotalF)))

    MsgBox "MaxTeam " & MaxTeam
    MsgBox "G " & TotalG
    MsgBox "D " & TotalD
    MsgBox "M " & TotalM
    MsgBox "F " & TotalF

        m = 0
        d = 0
        c = 1
        ct = 1
        a = 1
        r = 1

        l = 3
        b = 6

        'Place all the Min Goalkeepers,Forwards, Mid, Defenders
        For i = 2 To FinalRowI

            Name = Trim(wi.Range("A" & i).Text)
            Pos = Trim(wi.Range("B" & i).Text)
            Team = Trim(wi.Range("C" & i).Text)
            Sal = wi.Range("D" & i).Value

            Select Case Pos

            Case "G"

                If ct <= MaxTeam Then
                    wo.Range("A" & ct) = Name
                    wt.Range("A" & ct) = Team
                    ws.Range("A" & ct) = Sal
                    ct = ct + 1
                Else: End If

            Case "D"

                If d <= 3 * MaxTeam And r <= MaxTeam Then
                    wo.Cells(r, l) = Name
                    wt.Cells(r, l) = Team
                    ws.Cells(r, l) = Sal
                        d = d + 1
                        If d Mod 3 = 0 Then
                            r = r + 1
                            l = 3
                        Else
                            l = l + 1
                        End If
                Else: End If

            Case "M"

                If m <= 3 * MaxTeam And a <= MaxTeam Then
                    wo.Cells(a, b) = Name
                    wt.Cells(a, b) = Team
                    ws.Cells(a, b) = Sal
                    m = m + 1
                        If m Mod 3 = 0 Then
                            a = a + 1
                            b = 6
                        Else
                            b = b + 1
                        End If
                Else: End If

            Case "F"

                If c <= MaxTeam Then
                    wo.Range("B" & c) = Name
                    wt.Range("B" & c) = Team
                    ws.Range("B" & c) = Sal
                    c = c + 1
                Else: End If

            Case Else
            End Select
        Next i

     Set Drng = wo.Range(Cells(1, 3), Cells(MaxTeam, 5))
     Set Mrng = wo.Range(Cells(1, 6), Cells(MaxTeam, 8))

        m = 8
        d = 8
        c = 0
        ct = 0
        a = 1
        b = 1

        l = 3
        b = 6

'For Rest of three Places
    For i = 2 To FinalRow

        Name = Trim(wi.Range("A" & i).Text)
        Pos = Trim(wi.Range("B" & i).Text)
        Team = Trim(wi.Range("C" & i).Text)
        Sal = wi.Range("D" & i).Value

        Select Case Pos

        Case "G"

        Case "D"
            For Each c In Drng

            Next j

        Case "M"

        Case "F"

        Case Else
        End Select
    Next i

End Sub
How to&Answers:

I have placed a new version in Dropbox (as of 12/30/2015 @ 7:00pm EST)
https://www.dropbox.com/s/dvobwcpctolk18y/Permutations_REV3.xlsm?dl=0

** NOTE!! The code below is not complete due to size limitation!! I had to delete 7,000+ characters, so you will need to use the Dropbox code.

Please be aware that I added several new sheets to explain the process:
‘Math’ is used to indicate how many combinations of teams are permitted.
‘Limits’ tracks the names of teams the players come from.
‘Original’ is your original ‘Input’ sheet – easier to copy/paste for testing.

This solution tries to maximize the number of teams by using various combinations of team positions and player availability.

It was my understanding that ‘CORE’ players were to be selected first, but were not duplicated across teams. If that is incorrect, I can adjust.

The following is the code that is used, but I suggest that you grab the Dropbox version:

Option Explicit Dim WSi, WSo, WSt, WSs, WSl, WSm As Worksheet Dim iGLow As Integer Dim iGHigh As Integer Dim iDLow As Integer Dim iDHigh As Integer Dim iMLow As Integer Dim iMHigh As Integer Dim iFLow As Integer Dim iFHigh As Integer Dim iCol As Integer Dim iGoalies, iMidfield, iForward, iDefense As Integer Dim iGoaliesA, iMidfieldA, iForwardA, iDefenseA As Integer Dim iCoreG, iCoreD, iCoreF, iCoreM As Integer Dim iPlayers As Integer Dim iTeams As Integer Dim iRow As Integer Dim iTeamL As Integer Dim FSW As Boolean Dim FinalRowI As Long Dim lMaxSal As Long Dim iTeamRow As Integer Dim iGMin, IGMax As Integer Dim iDMin, IDMax As Integer Dim iFMin, IFMax As Integer Dim iMMin, IMMax As Integer Dim sCores As String Const cGoal = 13 Const cFwd = 15 Const cFwd2 = 18 Const cDef = 14 Const cDef2 = 17 Const cMid = 16 Const cMid2 = 19 Const cGA = 22 Const cDA = 23 Const cFA = 24 Const cMA = 25 Const cTTL = 20 Sub Teams() Dim i As Integer Dim iT As Integer Dim i2 As Integer Dim iGOAL, iFWD, iMID, iDEF As Integer On Error GoTo Error_Trap FSW = True If HouseKeeping = False Then MsgBox "Due to problems described earlier, this program will halt now. Please correct all problems.", vbOKOnly, "Program Halt" Exit Sub End If WSi.Activate For iTeamRow = 2 To iTeams + 1 DoEvents iCol = 1 ' Initialize the Output Column number starting position sCores = "" ' Use this to track CORE players per team iGOAL = 0: iFWD = 0: iMID = 0: iDEF = 0 If iTeamRow Mod 10 = 0 Then If ArrangeInputList = True Then MsgBox "Problem with number of players by position." End If End If If iGoaliesA > 0 Then iRow = FindAnyRow("G", iGLow, iGHigh) If iRow = 0 Then Debug.Print "Unable to make any more teams." WSo.Rows(iTeamRow).Delete GoTo Finish_Up End If iGoaliesA = iGoaliesA - 1 ' Decrease count of available by position... iGOAL = iGOAL + 1 Else Debug.Print "Bail out!" GoTo Finish_Up End If For i = 1 To WSm.Cells(2 + iTeamRow, cDef) + WSm.Cells(2 + iTeamRow, cDef2) iCol = iCol + 1 iRow = FindAnyRow("D", iDLow, iDHigh) If iRow = 0 Then Debug.Print "Unable to make any more teams." WSo.Rows(iTeamRow).Delete GoTo Finish_Up End If iDefenseA = iDefenseA - 1 ' Decrease count of available by position... iDEF = iDEF + 1 Next i For i = 1 To WSm.Cells(2 + iTeamRow, cFwd) + WSm.Cells(2 + iTeamRow, cFwd2) iCol = iCol + 1 iRow = FindAnyRow("F", iFLow, iFHigh) If iRow = 0 Then Debug.Print "Unable to make any more teams." WSo.Rows(iTeamRow).Delete GoTo Finish_Up End If iForwardA = iForwardA - 1 ' Decrease count of available by position... iFWD = iFWD + 1 Next i For i = 1 To WSm.Cells(2 + iTeamRow, cMid) + WSm.Cells(2 + iTeamRow, cMid2) iCol = iCol + 1 iRow = FindAnyRow("M", iMLow, iMHigh) If iRow = 0 Then Debug.Print "Unable to make any more teams." WSo.Rows(iTeamRow).Delete WSt.Rows(iTeamRow).Delete WSs.Rows(iTeamRow).Delete GoTo Finish_Up End If iMidfieldA = iMidfieldA - 1 ' Decrease count of available by position... iMID = iMID + 1 Next i ' Save Count by Position WSo.Cells(iTeamRow, 12) = iGOAL WSo.Cells(iTeamRow, 13) = iFWD WSo.Cells(iTeamRow, 14) = iDEF WSo.Cells(iTeamRow, 15) = iMID If (iGOAL <> 1) Or (iFWD > 3) Or (iMID > 5) Or (iDEF > 4) Then Debug.Print "Team composition exceeds limits: " & vbCrLf & _ "Goalies = " & iGOAL & vbTab & "Forwards = " & iFWD & vbTab & "Midfielders = " & iMID & vbTab & "Defenders = " & iDEF MsgBox "Team composition exceeds limits: " & vbCrLf & _ "Goalies = " & iGOAL & vbTab & "Forwards = " & iFWD & vbTab & "Midfielders = " & iMID & vbTab & "Defenders = " & iDEF End If If (iGOAL + iFWD + iMID + iDEF <> 11) Then Debug.Print "Team composition not enough players limits: " & vbCrLf & _ "Goalies = " & iGOAL & vbTab & "Forwards = " & iFWD & vbTab & "Midfielders = " & iMID & vbTab & "Defenders = " & iDEF MsgBox "Team composition exceeds limits: " & vbCrLf & _ "Goalies = " & iGOAL & vbTab & "Forwards = " & iFWD & vbTab & "Midfielders = " & iMID & vbTab & "Defenders = " & iDEF End If DoEvents Next iTeamRow Finish_Up: WSt.Activate Range("M2").Select ActiveCell = "=COUNTIF($A2:$K2,M$1)" '"=SUM(RC[-11]:RC[-1])" Range("M2").Select Selection.Copy Range("M2:AA" & Int(iTeams)).Select ActiveSheet.Paste ' Add Conditional Formatting to turn team count to yellow if > 4 players Cells.FormatConditions.Delete Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _ "=AND(OR(M2>4),M2<>"""")" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 End With Selection.FormatConditions(1).StopIfTrue = False Range("M2").Select Selection.Copy Range("M2:Z31").Select ActiveSheet.Paste Range("Q3").Select Application.CutCopyMode = False Audit_Checks: Dim sPlayer1 As String Dim sPlayer2 As String Dim sPosition As String Dim iRow1 As Integer Dim iRow2 As Integer Dim Rng1 As Range Dim Rng2 As Range Dim rCell As Range Dim iCol1 As Integer Dim iCol2 As Integer Dim iC1 As Integer Dim iR1 As Integer Dim sTeam As String If WSs.Cells(iTeamRow, 12) > lMaxSal Then Debug.Print "Team Salary = " & WSs.Cells(iTeamRow, 12) MsgBox "Team Salary of: " & WSs.Cells(iRow, 12) & " exceeds Limit of: " & lMaxSal End If ' Find first team with > 4 players from same team... For Each rCell In WSt.Range("M2:AD" & iTeams + 1).Cells If rCell.Value > 4 Then 'firstValue = rCell.Value iC1 = rCell.Column iR1 = rCell.Row For i = 2 To iTeams ' Find a row with less than 4 playes for this team... If WSt.Cells(i, iC1) < 4 Then ' If < 4, then we have a swap! iRow2 = i Debug.Print "Team #" & i - 1; " has only " & WSt.Cells(i, iC1) & " players from Team '" & WSt.Cells(1, iC1) & "'" sTeam = WSt.Cells(1, iC1) ' Now find a player to swap (must be same position also) For i2 = 2 To 11 If WSt.Cells(iR1, i2) = WSt.Cells(1, iC1) Then iRow1 = iR1 iCol1 = i2 sPlayer1 = WSo.Cells(iR1, i2) ' Get Players name & position sPosition = Right(sPlayer1, 3) sPlayer1 = Left(sPlayer1, Len(sPlayer1) - 4) Exit For End If Next i2 ' Now we need to find same position in the other team ' iRow2 contains Target Row For i2 = 2 To 11 If InStr(1, WSo.Cells(iRow2, i2), sPosition) > 0 And WSt.Cells(iRow2, i2) <> sTeam Then iCol2 = i2 sPlayer2 = WSo.Cells(iRow2, i2) sPlayer2 = Left(sPlayer2, Len(sPlayer2) - 4) Set Rng1 = WSo.Cells(iRow1, iCol1) Set Rng2 = WSo.Cells(iRow2, iCol2) If SwapPlayers(sPlayer1, Rng1, sPlayer2, Rng2) = False Then MsgBox "Failed to swap players: " & sPlayer1 & " with " & sPlayer2 End If GoTo Audit_Checks End If Next i2 End If Next i End If Next End_Of_Time: Debug.Print "----------------END OF TEAMS---------------------" Debug.Print "Remaining: " & vbCrLf & _ "Goalies : " & iGoaliesA & vbTab & "(Need 1)" & vbCrLf & _ "Forwards : " & iForwardA & vbTab & "(Need 1)" & vbCrLf & _ "Defense : " & iDefenseA & vbTab & "(Need 3)" & vbCrLf & _ "Midfield : " & iMidfieldA & vbTab & "(Need 3)" & vbCrLf Exit Sub Error_Trap: Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In: Teams" MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: Teams" Resume End Sub Function FindAnyRow(sPosition As String, iLow As Integer, iHigh As Integer) As Integer ' This function will receive the low and high row number for players by a position ' it will generate a random row number within that range, and if player not ' previously selected (X in 'selected' column), then will use that row #. ' As more players are taken from a range, the random number may spend too much time ' trying to find an unselected player in that range. If so, re-sort the list to exclude ' players that have already been selected. Dim i As Integer Dim iTries As Integer Dim iRow As Integer Dim FindRow As Range Dim iCLow As Integer Dim iTaken As Integer On Error GoTo Error_Trap 'Debug.Print "FindAnyRow: Pos=" & sPosition & vbTab & iLow & vbTab & iHigh If iHigh - iLow < 0 Then Debug.Print "How is this going to work?" & vbTab & iLow & vbTab & iHigh FindAnyRow = 0 Exit Function End If ' First let's check if we have a CORE player for this position ' Future change: once all core players have been assigned, bypass this code... iCLow = iLow ' Set low limit of rows to search for CORE Do DoEvents ' Having problems with 'Find' logic, so just use the K.I.S.S. method for now! For iRow = iCLow To iHigh If WSi.Range("E" & iRow) = 1 Then If InStr(1, sCores, WSi.Range("A" & iRow) & ",") = 0 Then sCores = sCores & WSi.Range("A" & iRow) & "," ' Add player to this team FindAnyRow = iRow ' Return the row # 'Debug.Print "Found CORE '" & sPosition & "' in row: " & iRow WSo.Cells(iTeamRow, iCol) = WSi.Range("A" & iRow) & " (" & sPosition & ")" WSt.Cells(iTeamRow, iCol) = WSi.Range("C" & iRow) WSs.Cells(iTeamRow, iCol) = WSi.Range("D" & iRow) ' If a CORE player - never mark as SELECTED. Thus will appear in every team 'WSi.Range("F" & iRow) = "X" Exit Function End If End If Next iRow Exit Do Loop ' Didn't find a CORE player, so let's find any player for this position! iTries = 0 Do DoEvents iTries = iTries + 1 ' Count # times we have tried to find available player. If iTries > 21 Then ' If more than 5, resort the list! ' ONE time during testing, the list was re-sorted, but then still failed to find a player. ' Just in case.... iTaken = 0 If iHigh - iLow <= 2 Then For i = iLow To iHigh If WSi.Range("E" & i) = 1 Or WSi.Range("F" & iRow) <> "X" Then iTaken = iTaken + 1 End If Next i End If If iTaken >= iHigh - iLow Then ' We have reached the limit on player combinations FindAnyRow = 0 Exit Function Else MsgBox "Random / resort not working!!" End If ElseIf iTries > 15 Then If ArrangeInputList = True Then Debug.Print "Problem with number of players by position." FindAnyRow = 0 Exit Function End If End If DoEvents iRow = Int((iHigh - iLow + 1) * Rnd + iLow) ' Get random number between low & high row 'Check if already selected If WSi.Range("F" & iRow) = " " And WSi.Range("E" & iRow) <> 1 Then FindAnyRow = iRow ' Return the row # WSo.Cells(iTeamRow, iCol) = WSi.Range("A" & iRow) & " (" & sPosition & ")" WSt.Cells(iTeamRow, iCol) = WSi.Range("C" & iRow) WSs.Cells(iTeamRow, iCol) = WSi.Range("D" & iRow) ' Don't mark a CORE by accident If WSi.Range("E" & iRow) <> 1 Then WSi.Range("F" & iRow) = "X" Else 'Debug.Print "Prevented marking player by mistake." End If Exit Do ' Exit the loop End If Loop Exit Function Error_Trap: Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In: FindAnyRow" MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: FindAnyRow" Resume End Function Function ArrangeInputList() As Boolean ' Sort the list of players by 'selected' column, then by position. Dim blnStop As Boolean On Error GoTo Error_Trap blnStop = False WSi.Activate Columns("A:F").Select ActiveWorkbook.Worksheets("Input").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Input").Sort.SortFields.Add Key:=Range("F2:F342") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("Input").Sort.SortFields.Add Key:=Range("B2:B342") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Input").Sort .SetRange Range("A1:F342") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With ' Now get the starting row for each position. WSi.Activate ' Range of Defense... iDLow = Range("B:B").Find(What:="D", After:=Range("B1")).Row ' Range of Forwards... iFLow = Range("B:B").Find(What:="F", After:=Range("B1")).Row ' Range of Goalies... iGLow = Range("B:B").Find(What:="G", After:=Range("B1")).Row ' Range of Midfielders... iMLow = Range("B:B").Find(What:="M", After:=Range("B1")).Row ' Calculate the ending row per position. Note: Can't search for MAX because prior 'selected' ' will still appear at the bottom of the list! iDHigh = iFLow - 1 iFHigh = iGLow - 1 iGHigh = iMLow - 1 ' The last group (Midfielders) needs some help! If FSW = True Then ' First time thru, this will be the last row for midfielders. FSW = False iMHigh = iPlayers Else ' Any other time thru, this will be the last row before a 'selected' flag. iMHigh = Range("F:F").Find(What:="X", After:=Range("F1")).Row End If ' Check validity If iGHigh < iGLow Then Debug.Print "WHAT>>>" blnStop = True End If If iDHigh < iDLow Then Debug.Print "WHAT>>>" blnStop = True End If If iFHigh < iFLow Then Debug.Print "WHAT>>>" blnStop = True End If If iMHigh < iMLow Then Debug.Print "WHAT>>>" blnStop = True End If ' Count new total # players by position... iDefense = iDHigh - iDLow + 1 iForward = iFHigh - iFLow + 1 iGoalies = iGHigh - iGLow + 1 iMidfield = iMHigh - iMLow + 1 ' Calculate new total # players AVAILABLE by position... iDefenseA = iDHigh - iDLow + 1 iForwardA = iFHigh - iFLow + 1 iGoaliesA = iGHigh - iGLow + 1 iMidfieldA = iMHigh - iMLow + 1 ' Debug.Print "Goalies Avail: " & iGoaliesA ' Debug.Print "Defenders Avail: " & iDefenseA ' Debug.Print "Forwards Avail: " & iForwardA ' Debug.Print "Midfielders Avail: " & iMidfieldA Exit Function Error_Trap: Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In: ArrangeInputList" MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: ArrangeInputList" Resume End Function Function SwapPlayers(sName1 As String, iRng1 As Range, sName2 As String, iRng2 As Range) As Boolean ' This routine will remove the selected player from their prior team and swap with another player. Dim i As Integer Dim iRow1 As Integer Dim iCol1 As Integer Dim iRow2 As Integer Dim iCol2 As Integer Dim FindRow As Integer Dim rFound As Range Dim sName As String Dim iLen As Integer Dim lSalary1 As Long Dim lSalary2 As Long Dim sTeam1 As String Dim sTeam2 As String Dim sN1 As String Dim sN2 As String On Error GoTo Error_Trap Debug.Print iRng1.Address & vbTab & iRng1.Row & "/" & iRng1.Column Debug.Print iRng2.Address & vbTab & iRng2.Row & "/" & iRng2.Column ' Find first player With WSi Set rFound = .Range("A2:A" & FinalRowI).Find(What:=sName1, LookIn:=xlValues) End With If Not rFound Is Nothing Then iRow1 = rFound.Row Else ' Impossible? MsgBox "Unable to find player: " & sName1 End If ' Find second player With WSi Set rFound = .Range("A2:A" & FinalRowI).Find(What:=sName2, LookIn:=xlValues) End With If Not rFound Is Nothing Then iRow2 = rFound.Row Else ' Impossible? MsgBox "Unable to find player: " & sName1 End If ' Get Salary and Team names sTeam1 = WSi.Cells(iRow1, 3) sTeam2 = WSi.Cells(iRow2, 3) lSalary1 = WSi.Cells(iRow1, 4) lSalary2 = WSi.Cells(iRow2, 4) sN1 = WSo.Cells(iRng1.Row, iRng1.Column) sN2 = WSo.Cells(iRng2.Row, iRng2.Column) ' Make the swap Debug.Print "Swap: " & sName1 & vbTab & sTeam1 & vbTab & lSalary1 & vbTab & "in RC:" & "" Debug.Print "With: " & sName2 & vbTab & sTeam2 & vbTab & lSalary2 & vbTab & "in RC:" & "" 'Debug.Print WSo.Cells(iRng1.Row, iRng1.Column) & vbTab & WSt.Cells(iRng1.Row, iRng1.Column) & vbTab & WSs.Cells(iRng1.Row, iRng1.Column) 'Debug.Print WSo.Cells(iRng2.Row, iRng2.Column) & vbTab & WSt.Cells(iRng2.Row, iRng2.Column) & vbTab & WSs.Cells(iRng2.Row, iRng2.Column) WSo.Cells(iRng1.Row, iRng1.Column) = sN2 WSo.Cells(iRng2.Row, iRng2.Column) = sN1 WSt.Cells(iRng1.Row, iRng1.Column) = sTeam2 WSt.Cells(iRng2.Row, iRng2.Column) = sTeam1 WSs.Cells(iRng1.Row, iRng1.Column) = lSalary2 WSs.Cells(iRng2.Row, iRng2.Column) = lSalary1 SwapPlayers = True Exit Function Error_Trap: Debug.Print Err.Number & vbTab & Err.Description & vbCrLf & "In: SwapPlayer" MsgBox Err.Number & vbTab & Err.Description & vbCrLf & "In: SwapPlayer" Exit Function End Function Function HouseKeeping() As Boolean ' General setup code to: ' - Clear sheet contents ' - Get Team Names ' - Calculate makeup of teams by positions (Math worksheet) Dim i As Integer Dim i2 As Integer Dim iSum As Integer Dim blnFail As Boolean Dim iHalf As Integer Dim iCtr As Integer Dim bSkipBalance As Boolean On Error GoTo Error_Trap blnFail = False ' Set default to 'FAIL' mode - if good exit, change to pass Set WSi = Sheet1 Set WSo = Sheet2 Set WSt = Sheet3 Set WSs = Sheet4 Set WSl = Sheet5 Set WSm = Sheet8 Sheet2.Cells.ClearContents Sheet3.Cells.ClearContents Sheet4.Cells.ClearContents Sheet5.Cells.ClearContents iGMin = WSi.Cells(17, 8): IGMax = WSi.Cells(17, 9) iDMin = WSi.Cells(18, 8): IDMax = WSi.Cells(18, 9) iFMin = WSi.Cells(19, 8): IFMax = WSi.Cells(19, 9) iMMin = WSi.Cells(20, 8): IMMax = WSi.Cells(20, 9) WSo.Cells(1, 1) = "Goalie" WSo.Cells(1, 2) = "2" WSo.Cells(1, 3) = "3" WSo.Cells(1, 4) = "4" WSo.Cells(1, 12) = "# G" WSo.Cells(1, 13) = "# D" WSo.Cells(1, 14) = "# F" WSo.Cells(1, 15) = "# M" ' Get last row, which is # Players +1 FinalRowI = WSi.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row iPlayers = FinalRowI - 1 ' Clear 'Selected' column - used to indicate a player has been assigned a team WSi.Activate Range("F2").Select ActiveCell.Value = " " ' need one space for sort to work properly Range("F2").Select Selection.Copy Range("F3:F" & FinalRowI).Select ActiveSheet.Paste ' Setup Math worksheet... WSm.Activate ' Count Players by position. Place in Math worksheet WSm.Cells(4, 4) = Application.WorksheetFunction.CountIf(Workbooks(1).Sheets(1).Range("B2:B" & FinalRowI), "G") WSm.Cells(5, 4) = Application.WorksheetFunction.CountIf(Workbooks(1).Sheets(1).Range("B2:B" & FinalRowI), "D") WSm.Cells(6, 4) = Application.WorksheetFunction.CountIf(Workbooks(1).Sheets(1).Range("B2:B" & FinalRowI), "F") WSm.Cells(7, 4) = Application.WorksheetFunction.CountIf(Workbooks(1).Sheets(1).Range("B2:B" & FinalRowI), "M") ' In theory, this is the max number of teams iTeams = FinalRowI / 11 ' Do we have enough Goalies to make teams? If WSm.Cells(4, 4) < iTeams Then iTeams = WSm.Cells(4, 4) End If ' Get # Core players iCoreG = 0: iCoreD = 0: iCoreF = 0: iCoreM = 0: For i = 2 To FinalRowI If WSi.Cells(i, 5) = 1 Then If WSi.Cells(i, 2) = "G" Then iCoreG = iCoreG + 1 ElseIf WSi.Cells(i, 2) = "D" Then iCoreD = iCoreD + 1 ElseIf WSi.Cells(i, 2) = "F" Then iCoreF = iCoreF + 1 ElseIf WSi.Cells(i, 2) = "M" Then iCoreM = iCoreM + 1 End If End If Next i ' Clear Map of team composition WSm.Range("L4:Y300").Select Application.CutCopyMode = False Selection.ClearContents i = 0 ' Loop as long as we can build a team.... Do bSkipBalance = False i = i + 1 WSm.Cells(3 + i, cTTL).FormulaR1C1 = "=SUM(RC[-7]:RC[-1])" ' Add formula to sum count of players on team If iCoreG = 0 Then WSm.Cells(3 + i, cGA).FormulaR1C1 = "=R[-1]C-RC[-9]" ' Goalie Remainder Else WSm.Cells(3 + i, cGA).FormulaR1C1 = "=R[-1]C" ' No limit on goalie End If If iCoreD = 0 Then WSm.Cells(3 + i, cDA).FormulaR1C1 = "=R[-1]C-RC[-9]-RC[-6]" ' Defender Remainder Else WSm.Cells(3 + i, cDA).FormulaR1C1 = "=R[-1]C-RC[-9]-RC[-6]+" & iCoreD ' Defender Remainder End If If iCoreF = 0 Then WSm.Cells(3 + i, cFA).FormulaR1C1 = "=R[-1]C-RC[-9]-RC[-6]" ' Forward Remainder Else WSm.Cells(3 + i, cFA).FormulaR1C1 = "=R[-1]C-RC[-9]-RC[-6]+" & iCoreF ' Forward Remainder End If If iCoreM = 0 Then WSm.Cells(3 + i, cMA).FormulaR1C1 = "=R[-1]C-RC[-9]-RC[-6]" ' Midfielder Remainder Else WSm.Cells(3 + i, cMA).FormulaR1C1 = "=R[-1]C-RC[-9]-RC[-6]+" & iCoreM ' Midfielder Remainder End If WSm.Cells(3 + i, 12) = i ' Set map of positions WSm.Cells(3 + i, cGoal) = 1 WSm.Cells(3 + i, cDef) = 3 WSm.Cells(3 + i, cFwd) = 1 WSm.Cells(3 + i, cMid) = 3 ' If we have Excess Defenders, use them (can ONLY use ONE more!!) If WSm.Cells(3 + i, 12) > WSm.Cells(3 + i, cDA) Then ' was WSm.Cells(5, 9) WSm.Cells(3 + i, cDef2) = 0 Else WSm.Cells(3 + i, cDef2) = 1 End If 

Answer:

Consider an SQL solution which runs random iterations of the 11-player sequence and validates each iteration to meet all required conditions. MS Access, which works great with its Office sibling MS Excel can be a viable solution. Also, any RDMS can run below in a stored procedure. Below is the sequence of events and needed objects. Here is the MS Access accdb app empty of any picks for your testing.

Table

First, create a final table SoccerPicks to hold all 11 member teams which will grow over lifetime of app. It is used in append query called by VBA module below, inserting a successfully validated team record per each looped iteration.

Cross Join Query

Second, create a randomized Cross Join Query (returns all possible combinations of a choice set) but selects one player per 11 player tables and conditions the Positions (G, D, M, F) counts. In the FROM clause, the first four correspond to four core players and these individuals will show up on every team. Replicate their derived tables for more or remove and copy a randomized derived table as the other 7 are set up.

SELECT Player1, Player2, Player3, Player4, Player5, Player6, Player7, Player8, Player9, Player10, Player11, (t1.Salary + t2.Salary + t3.Salary + t4.Salary + t5.Salary + t6.Salary + t7.Salary + t8.Salary + t9.Salary + t10.Salary + t11.Salary) AS TeamSalary, IIF(t1.Position = 'G', 1, 0) + IIF(t2.Position = 'G', 1, 0) + IIF(t3.Position = 'G', 1, 0) + IIF(t4.Position = 'G', 1, 0) + IIF(t5.Position = 'G', 1, 0) + IIF(t6.Position = 'G', 1, 0) + IIF(t7.Position = 'G', 1, 0) + IIF(t8.Position = 'G', 1, 0) + IIF(t9.Position = 'G', 1, 0) + IIF(t10.Position = 'G', 1, 0) + IIF(t11.Position = 'G', 1, 0) AS GPosition, IIF(t1.Position = 'D', 1, 0) + IIF(t2.Position = 'D', 1, 0) + IIF(t3.Position = 'D', 1, 0) + IIF(t4.Position = 'D', 1, 0) + IIF(t5.Position = 'D', 1, 0) + IIF(t6.Position = 'D', 1, 0) + IIF(t7.Position = 'D', 1, 0) + IIF(t8.Position = 'D', 1, 0) + IIF(t9.Position = 'D', 1, 0) + IIF(t10.Position = 'D', 1, 0) + IIF(t11.Position = 'D', 1, 0) AS DPosition, IIF(t1.Position = 'M', 1, 0) + IIF(t2.Position = 'M', 1, 0) + IIF(t3.Position = 'M', 1, 0) + IIF(t4.Position = 'M', 1, 0) + IIF(t5.Position = 'M', 1, 0) + IIF(t6.Position = 'M', 1, 0) + IIF(t7.Position = 'M', 1, 0) + IIF(t8.Position = 'M', 1, 0) + IIF(t9.Position = 'M', 1, 0) + IIF(t10.Position = 'M', 1, 0) + IIF(t11.Position = 'M', 1, 0) AS MPosition, IIF(t1.Position = 'F', 1, 0) + IIF(t2.Position = 'F', 1, 0) + IIF(t3.Position = 'F', 1, 0) + IIF(t4.Position = 'F', 1, 0) + IIF(t5.Position = 'F', 1, 0) + IIF(t6.Position = 'F', 1, 0) + IIF(t7.Position = 'F', 1, 0) + IIF(t8.Position = 'F', 1, 0) + IIF(t9.Position = 'F', 1, 0) + IIF(t10.Position = 'F', 1, 0) + IIF(t11.Position = 'F', 1, 0) AS FPosition FROM (SELECT PlayerName as Player1, Position, Team, Salary FROM Soccer WHERE [Core Player] = True AND (SELECT Count(*) FROM Soccer sub WHERE sub.ID <= Soccer.ID AND sub.[Core Player] = True AND Soccer.[Core Player] = True) = 1) AS t1, (SELECT PlayerName as Player2, Position, Team, Salary FROM Soccer WHERE [Core Player] = True AND (SELECT Count(*) FROM Soccer sub WHERE sub.ID <= Soccer.ID AND sub.[Core Player] = True AND Soccer.[Core Player] = True) = 2) AS t2, (SELECT PlayerName as Player3, Position, Team, Salary FROM Soccer WHERE [Core Player] = True AND (SELECT Count(*) FROM Soccer sub WHERE sub.ID <= Soccer.ID AND sub.[Core Player] = True AND Soccer.[Core Player] = True) = 3) AS t3, (SELECT PlayerName as Player4, Position, Team, Salary FROM Soccer WHERE [Core Player] = True AND (SELECT Count(*) FROM Soccer sub WHERE sub.ID <= Soccer.ID AND sub.[Core Player] = True AND Soccer.[Core Player] = True) = 4) AS t4, (SELECT TOP 1 PlayerName AS Player5, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t5, (SELECT TOP 1 PlayerName AS Player6, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t6, (SELECT TOP 1 PlayerName AS Player7, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t7, (SELECT TOP 1 PlayerName AS Player8, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t8, (SELECT TOP 1 PlayerName AS Player9, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t9, (SELECT TOP 1 PlayerName AS Player10, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t10, (SELECT TOP 1 PlayerName AS Player11, Position, Team, Salary FROM Soccer ORDER BY Rnd(ID)) AS t11 WHERE IIF(t1.Position = 'G', 1, 0) + IIF(t2.Position = 'G', 1, 0) + IIF(t3.Position = 'G', 1, 0) + IIF(t4.Position = 'G', 1, 0) + IIF(t5.Position = 'G', 1, 0) + IIF(t6.Position = 'G', 1, 0) + IIF(t7.Position = 'G', 1, 0) + IIF(t8.Position = 'G', 1, 0) + IIF(t9.Position = 'G', 1, 0) + IIF(t10.Position = 'G', 1, 0) + IIF(t11.Position = 'G', 1, 0) = 1 AND IIF(t1.Position = 'D', 1, 0) + IIF(t2.Position = 'D', 1, 0) + IIF(t3.Position = 'D', 1, 0) + IIF(t4.Position = 'D', 1, 0) + IIF(t5.Position = 'D', 1, 0) + IIF(t6.Position = 'D', 1, 0) + IIF(t7.Position = 'D', 1, 0) + IIF(t8.Position = 'D', 1, 0) + IIF(t9.Position = 'D', 1, 0) + IIF(t10.Position = 'D', 1, 0) + IIF(t11.Position = 'D', 1, 0) BETWEEN 3 AND 4 AND IIF(t1.Position = 'M', 1, 0) + IIF(t2.Position = 'M', 1, 0) + IIF(t3.Position = 'M', 1, 0) + IIF(t4.Position = 'M', 1, 0) + IIF(t5.Position = 'M', 1, 0) + IIF(t6.Position = 'M', 1, 0) + IIF(t7.Position = 'M', 1, 0) + IIF(t8.Position = 'M', 1, 0) + IIF(t9.Position = 'M', 1, 0) + IIF(t10.Position = 'M', 1, 0) + IIF(t11.Position = 'M', 1, 0) BETWEEN 3 AND 5 AND IIF(t1.Position = 'F', 1, 0) + IIF(t2.Position = 'F', 1, 0) + IIF(t3.Position = 'F', 1, 0) + IIF(t4.Position = 'F', 1, 0) + IIF(t5.Position = 'F', 1, 0) + IIF(t6.Position = 'F', 1, 0) + IIF(t7.Position = 'F', 1, 0) + IIF(t8.Position = 'F', 1, 0) + IIF(t9.Position = 'F', 1, 0) + IIF(t10.Position = 'F', 1, 0) + IIF(t11.Position = 'F', 1, 0) BETWEEN 1 AND 3 AND (t1.Salary + t2.Salary + t3.Salary + t4.Salary + t5.Salary + t6.Salary + t7.Salary + t8.Salary + t9.Salary + t10.Salary + t11.Salary) <= 100000000; 

Soccer Permutations Cross Join Query

VBA Module

Next is the VBA module that runs an append and delete queries (to remove failed records that do not meet other constraints). Notice the for loop at 50 iterations. Increase as needed, knowing there is quite a bit of choice sets with 11 players. Iterations are needed because above query may return zero depending on that random draw and the WHERE logic conditioning. NOTE: First two delete queries require a union query to stack all players in first above query to better aggregate team counts, player counts, and team salary summation. See attached app.

Public Function IteratePicks() Dim db As Database Dim i As Integer Set db = CurrentDb For i = 1 To 50 db.Execute "INSERT INTO SoccerPicks SELECT * FROM SoccerTeamPicksQ", dbFailOnError ' DELETING TEAMS WITH DUPLICATE PLAYERS db.Execute "DELETE FROM SoccerPicks" _ & " WHERE SoccerPicks.ID IN" _ & " (SELECT ID" _ & " FROM (SELECT SoccerPicksUnionQ.ID, SoccerPicksUnionQ.Player, Count(*) AS PlayerCount" _ & " FROM SoccerPicksUnionQ " _ & " GROUP BY SoccerPicksUnionQ.ID, SoccerPicksUnionQ.Player" _ & " HAVING Count(*) > 1) AS dT);", dbFailOnError ' DELETING TEAMS WITH TEAM PLAYER COUNT > 4 db.Execute "DELETE FROM SoccerPicks" _ & " WHERE SoccerPicks.ID IN" _ & " (SELECT ID AS MaxID" _ & " FROM (SELECT SoccerPicksUnionQ.ID, SoccerPicksUnionQ.Team, Count(*) AS TeamCount" _ & " FROM SoccerPicksUnionQ" _ & " GROUP BY SoccerPicksUnionQ.ID, SoccerPicksUnionQ.Team) AS dT" _ & " GROUP BY ID" _ & " HAVING Max(TeamCount) >= 4);", dbFailOnError ' DELETING TEAMS WITH SAME PLAYERS (I.E. SAME SALARY) db.Execute "DELETE FROM SoccerPicks" _ & " WHERE ID IN" _ & " (SELECT ID AS MaxID" _ & " FROM SoccerPicks" _ & " WHERE TeamSalary IN" _ & " (SELECT sub.TeamSalary" _ & " FROM SoccerPicks sub" _ & " WHERE sub.ID < SoccerPicks.ID));", dbFailOnError Next i Set db = Nothing MsgBox "Successfully completed!", vbInformation End Function