Sub MakePlayerPairingsList()
Dim vBoysNames As Variant, vGirlsNames As Variant
Dim vAllNames As Variant, vResults As Variant
'--read names from two named ranges (add validation if needed)
vBoysNames = Range("BoysList").Value
vGirlsNames = Range("GirlsList").Value
'--add a column to arrays with group numbers of pairings
vBoysNames = vAssignGroups(vPlayers:=vBoysNames, _
lFirstGroup:=1, lIncrementsGroupsBy:=2)
vGirlsNames = vAssignGroups(vPlayers:=vGirlsNames, _
lFirstGroup:=2, lIncrementsGroupsBy:=2)
'--write results to new worksheet
With Worksheets.Add
.Range("A2").Resize(UBound(vBoysNames, 1), _
UBound(vBoysNames, 2)).Value = vBoysNames
.Range("A2").Offset(UBound(vBoysNames, 1)) _
.Resize(UBound(vGirlsNames, 1), _
UBound(vGirlsNames, 2)).Value = vGirlsNames
With .Range("A1").CurrentRegion
.Sort Key1:=.Range("B1"), Order1:=xlAscending, _
Header:=xlYes, Orientation:=xlTopToBottom
End With
'--replace group numbers with tee times
AssignTeeTimes rGroupNumbers:=.Range("B2:B" & _
.Cells(.Rows.Count, "B").End(xlUp).Row), _
dtStart:=TimeValue("08:30"), _
dtIncrement:=TimeValue("00:08")
.Range("A1:B1") = Array("Player Name", "Tee Time")
.UsedRange.EntireColumn.AutoFit
End With
End Sub
Private Sub AssignTeeTimes(ByVal rGroupNumbers As Range, _
ByVal dtStart As Date, ByVal dtIncrement As Date)
Dim dtTeeTime As Date
Dim sLastGroup As String
Dim rGroup As Range
'--initial values
dtTeeTime = dtStart
sLastGroup = rGroupNumbers(1)
For Each rGroup In rGroupNumbers
If rGroup.Value <> sLastGroup Then
'--next group
sLastGroup = rGroup.Value
dtTeeTime = dtTeeTime + dtIncrement
End If
rGroup.Value = dtTeeTime
Next rGroup
rGroupNumbers.NumberFormat = "h:mm AM/PM"
End Sub
Private Function vAssignGroups(ByVal vPlayers As Variant, _
ByVal lFirstGroup As Long, ByVal lIncrementsGroupsBy As Long) As Variant
'---assumes input vPlayers is a 2D array and first column has players names.
' Returns array that has added column with group numbers of pairings.
' Assigns 3 players per group until need to switch to
' 4 players per groups to have remainder of 0.
' Group numbers start at lFirstGroup and increase by lIncrementsGroupsBy
Dim lCountOfPlayers As Long, lLastInThreesome As Long
Dim lSpotsInGroup As Long, lSpotsOpen As Long
Dim lGroup As Long, lNdx As Long, lGroupCol As Long
lGroupCol = UBound(vPlayers, 2) + 1
lCountOfPlayers = UBound(vPlayers, 1)
'--adds a field for Group Assignments
ReDim Preserve vPlayers(1 To lCountOfPlayers, 1 To lGroupCol)
'--calculate when groups must switch to foursomes
lLastInThreesome = lCountOfPlayers - 4 * (lCountOfPlayers Mod 3)
'--start with 3 per group except case of 4 or 8 players
Select Case lCountOfPlayers
Case 4, 8: lSpotsInGroup = 4
Case Else: lSpotsInGroup = 3
End Select
lSpotsOpen = lSpotsInGroup
lGroup = lFirstGroup
For lNdx = 1 To lCountOfPlayers
If lSpotsOpen = 0 Then
'--start new group with all spots open
lGroup = lGroup + lIncrementsGroupsBy
lSpotsOpen = lSpotsInGroup
End If
'--assign group to player
vPlayers(lNdx, lGroupCol) = lGroup
lSpotsOpen = lSpotsOpen - 1
If lNdx = lLastInThreesome Then
lSpotsInGroup = 4
End If
Next lNdx
vAssignGroups = vPlayers
End Function
Sub MakePlayerPairings2StartTees()
'--builds two paring lists from two list of players
' starting at different tees.
Dim vTee1Data As Variant, vTee10Data As Variant
'--read player data from two named ranges
' this example: Name, Team
vTee1Data = Range("Tee1List").Value
vTee10Data = Range("Tee10List").Value
'--add a column to arrays with group numbers of pairings
vTee1Data = vAssignGroups(vPlayers:=vTee1Data, _
lFirstGroup:=1, lIncrementsGroupsBy:=1)
vTee10Data = vAssignGroups(vPlayers:=vTee10Data, _
lFirstGroup:=1, lIncrementsGroupsBy:=1)
'--add a column to arrays with starting tees
vTee1Data = vAddStartTees(vPlayers:=vTee1Data, _
lStartTee:=1)
vTee10Data = vAddStartTees(vPlayers:=vTee10Data, _
lStartTee:=10)
'--write results to new worksheet
With Worksheets.Add
'--write Tee 1 start data
.Range("A1:D1") = Array("Name", "School", "Tee Time", "Tee Number")
.Range("A2").Resize(UBound(vTee1Data, 1), _
UBound(vTee1Data, 2)).Value = vTee1Data
'--replace group numbers with tee times- Tee 1
AssignTeeTimes rGroupNumbers:=.Range("C2:C" & _
.Cells(.Rows.Count, "C").End(xlUp).Row), _
dtStart:=TimeValue("08:30"), _
dtIncrement:=TimeValue("00:08")
'--write Tee 10 start data
.Range("F1:i1") = Array("Name", "School", "Tee Time", "Tee Number")
.Range("F2").Resize(UBound(vTee10Data, 1), _
UBound(vTee10Data, 2)).Value = vTee10Data
'--replace group numbers with tee times-Tee 10
AssignTeeTimes rGroupNumbers:=.Range("H2:H" & _
.Cells(.Rows.Count, "H").End(xlUp).Row), _
dtStart:=TimeValue("08:30"), _
dtIncrement:=TimeValue("00:08")
.UsedRange.EntireColumn.AutoFit
End With
End Sub
