Algorithm 从列表中选择项目
问题: 下面的格式中有N名足球运动员，表中每11名球员的组合将显示一次 每个11人的阵容必须遵循以下限制条件 它应该能够选择球员作为“核心”，这意味着他们将出现在100%的输出阵容 输入：Algorithm 从列表中选择项目,algorithm,vba,excel,combinations,Algorithm,Vba,Excel,Combinations,问题: 下面的格式中有N名足球运动员，表中每11名球员的组合将显示一次 每个11人的阵容必须遵循以下限制条件 它应该能够选择球员作为“核心”，这意味着他们将出现在100%的输出阵容 输入： A B C D E Name Position Team Salary Core Player? 1="Yes",0="No" Darron Gibson M EVE
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
选项显式
小组（）
尺寸wi、wo、wt、ws作为工作表
尺寸i、j、l、d、m、ct、c、a、b、r等于长度
Dim TotalG、TotalD、TotalM、TotalF、TotalSal、Sal、SalLeft、MaxTeam和长
Dim团队，Pos，名称为字符串
暗淡的最后一条路，最后一条路一样长
变暗Drng As范围
变暗Mrng As范围
设置wi=1
设置wo=表2
设置wt=表3
设置ws=4
FinalRowI=wi.范围（“A900000”）.结束（xlUp）.行
总g=0
总计d=0
TotalM=0
TotalF=0
萨尔=0
SalLeft=0
TotalSal=wi.范围（“H14”）值
对于i=2至最终箭头i
名称=修剪（wi.Range（“A”&i）.Text）
位置=修剪（wi.范围（“B”和i）.文本）
团队=修剪（wi.范围（“C”和i）.文本）
Sal=wi.范围（“D”&i）.值
选择案例位置
案例“G”
TotalG=TotalG+1
案例“D”
TotalD=TotalD+1
案例“M”
TotalM=TotalM+1
案例“F”
TotalF=TotalF+1
其他情况
结束选择
接下来我
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
“安排所有的Min守门员、前锋、中场和后卫
对于i=2至最终箭头i
名称=修剪（wi.Range（“A”&i）.Text）
位置=修剪（wi.范围（“B”和i）.文本）
团队=修剪（wi.范围（“C”和i）.文本）
Sal=wi.范围（“D”&i）.值
选择案例位置
案例“G”
如果ct考虑一个SQL解决方案，它运行11个播放器序列的随机迭代，并验证每个迭代以满足所有要求的条件。MS Access与它的Office同级MS Excel配合使用效果很好，是一个可行的解决方案。此外，任何RDM都可以在存储过程中运行。下面是事件和所需对象的顺序。这是供您测试的所有选项的空白
表格
首先，创建一个最终表格SoccerPicks
，以容纳所有11个成员团队，这些团队将在应用程序的生命周期内成长。它用于下面VBA模块调用的追加查询中，在每个循环迭代中插入成功验证的团队记录
交叉连接查询
第二，创建一个（返回一个选择集的所有可能组合），但每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;
我已在Dropbox中放置了一个新版本（截至2015年12月30日东部时间下午7:00）
**注意！！由于尺寸限制，下面的代码不完整！！我不得不删除7000多个字符，因此您需要使用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
选项显式
Dim WSi、WSo、WSt、WSs、WSl、WSm As工作表
将iGLow设置为整数
高达整数
Dim iDLow作为整数
Dim iDHigh为整数
将iMLow设置为整数
Dim iMHigh为整数
Dim iFLow作为整数
高达整数
作为整数的Dim-iCol
Dim IGALIES、iMidfield、iForward、iDefense作为整数
Dim iGoaliesA、IMIDFEELDA、iForwardA、iDefenseA作为整数
Dim iCoreG、iCoreD、iCoreF、iCoreM作为整数
将IPLAYES设置为整数
作为整数的Dim iTeams
Dim iRow作为整数
Dim iTeamL作为整数
模糊FSW为布尔型
模糊的最后一条路
暗轴与长轴相同
Dim iTeamRow作为整数
Dim iGMin，IGMax为整数
Dim iDMin，IDMax为整数
Dim iFMin，IFMax为整数
Dim iMMin，IMMax为整数
将分数变暗为字符串
常数cGoal=13
常数cFwd=15
常数cFwd2=18
常数cDef=14
常数cDef2=17
常数cMid=16
常数cMid2=19
常数cGA=22
常数cDA=23
常数cFA=24
常数cMA=25
常数cTTL=20
小组（）
作为整数的Dim i
将其设置为整数
作为整数的Dim i2
Dim iGOAL、iFWD、iMID、iDEF作为整数
关于错误转到错误陷阱
FSW=真
如果内务管理=False，则
MsgBox“由于前面描述的问题，此程序将立即停止。请更正所有问题。”，vbOKOnly，“程序停止”
出口接头
如果结束
激活
对于iTeamRow=2到iTeams+1
多芬特
iCol=1'初始化输出列编号起始位置
分数=“使用此项跟踪每个团队的核心球员
iGOAL=0:iFWD=0:
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
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