Question

问题：

下面的格式有N个足球运动员，每张11人的球员组合将会出来。

每个11人阵容必须遵循以下限制。

它应该能够选择球员作为“核心”，这意味着他们将出现在100％的输出阵容中。

输入：

  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

每个团队的约束：

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

输出示例：

    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

我的想法是首先放置它们，然后检查约束条件，因为它们的选择顺序并不重要，并且在条件满足之前使它们正确但在每个阶段都变得复杂。

我尝试过的（不完整）：

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

Answer 1

考虑一个SQL解决方案，该解决方案运行11个玩家序列的随机迭代，并验证每次迭代以满足所有必需条件。 MS Access与Office兄弟MS Excel配合使用可能是一个可行的解决方案。此外，任何RDMS都可以在存储过程中运行。以下是事件和所需对象的顺序。以下是您测试的任何选择的MS Access accdb app空。

表格

首先，创建一个决赛桌SoccerPicks，以容纳所有11个成员团队，这些团队将在应用程序的生命周期内增长。它用于下面的VBA模块调用的追加查询，为每个循环迭代插入一个成功验证的团队记录。

交叉加入查询

其次，创建一个randomized Cross Join Query（返回选择集的所有可能组合），但每11个玩家表中选择一个玩家并调整位置（G，D，M，F）计数。在FROM条款中，前四个对应四个核心玩家，这些人将出现在每个团队中。复制其派生表以获取更多信息，或者在设置其他7时删除并复制随机派生表。

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;

VBA模块

接下来是运行追加和删除查询的VBA模块（用于删除不符合其他约束的失败记录）。注意50次迭代的for循环。根据需要增加，知道有11个玩家有相当多的选择集。需要迭代，因为上面的查询可能会返回零，具体取决于随机抽取和WHERE逻辑调节。注意：前两个删除查询需要联合查询来堆叠上面第一个查询中的所有玩家，以更好地聚合团队计数，玩家数量和团队工资总和。请参阅随附的应用程序。

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

Answer 2

我在Dropbox中放置了一个新版本（截至2015年12月30日美国东部时间下午7点） https://www.dropbox.com/s/dvobwcpctolk18y/Permutations_REV3.xlsm?dl=0

**注意!!由于尺寸限制，以下代码不完整!!我不得不删除7,000多个字符，因此您需要使用Dropbox代码。

请注意，我添加了几张新表来解释这个过程： “数学”用于表示允许的团队组合数量。 “限制”跟踪球员来自的球队名称。 “原始”是您原来的“输入”表 - 更容易复制/粘贴以进行测试。

此解决方案尝试通过使用团队位置和玩家可用性的各种组合来最大化团队数量。

我的理解是，首先选择“核心”球员，但不会在球队之间重复。如果这不正确，我可以调整。

以下是使用的代码，但我建议你抓住Dropbox版本：

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

从列表中选择项目

2 个答案: