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