从列表中select项目

问题：

有N个足球运动员在下面的格式和表将吐出每个球员的11个球员组合。

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

它应该能够将玩家select为“核心”，这意味着他们将出现在100％的输出阵容中。

input：

ABCDE 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 ' eg 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 

附件

我的想法是首先将它们放置，然后检查约束条件，因为它们被select的顺序并不重要，使它们正确，直到条件满足为止，但是这在每个阶段都变得复杂。

我试过的（不完整）：

 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

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

** 注意！！ 由于尺寸限制，下面的代码不完整！ 我不得不删除7000多个字符，所以您将需要使用Dropbox代码。

请注意，我添加了几张新的表格来解释这个过程：“math”用于表示允许多less组合的组合。 “限制”跟踪球员来自队伍的名字。 “原始”是您的原始“input”表 – 更容易复制/粘贴testing。

该解决scheme试图通过使用团队职位和玩家可用性的各种组合来最大化团队数量。

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

以下是使用的代码，但我build议您抓住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 KISS 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 2

考虑一个SQL解决scheme，它运行11个玩家序列的随机迭代，并validation每个迭代满足所有要求的条件。 MS Access可以很好地与Office的兄弟MS Excel一起使用，是一个可行的解决scheme。 而且，任何RDMS都可以在存储过程中运行。 以下是事件和所需对象的顺序。 这里是MS Access accdb应用程序空的任何select您的testing。

表

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

交叉连接查询

其次，创build一个随机 交叉联合查询 （返回一个select集合的所有可能的组合），但是每11个选手表格select一个玩家，并且位置（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 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 (IE 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