从列表中选择项目
问题：
下面的格式有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
我的想法是首先放置它们，然后检查约束条件，因为它们的选择顺序并不重要，并且在条件满足之前使它们正确但在每个阶段都变得复杂。
我尝试过的（不完整）：
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
2 个答案:
答案 0 :(得分：4)
考虑一个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
答案 1 :(得分：1)
我在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
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？