Option Explicit

#Const I_Want_Colors = True

#If I_Want_Colors Then
Private Enum xlCI 'Excel Color Index
: xlCIBlack = 1: xlCIWhite: xlCIRed: xlCIBrightGreen: xlCIBlue '1 - 5
: xlCIYellow: xlCIPink: xlCITurquoise: xlCIDarkRed: xlCIGreen '6 - 10
: xlCIDarkBlue: xlCIDarkYellow: xlCIViolet: xlCITeal: xlCIGray25 '11 - 15
: xlCIGray50: xlCIPeriwinkle: xlCIPlum: xlCIIvory: xlCILightTurquoise '16 - 20
: xlCIDarkPurple: xlCICoral: xlCIOceanBlue: xlCIIceBlue: xlCILightBrown '21 - 25
: xlCIMagenta2: xlCIYellow2: xlCICyan2: xlCIDarkPink: xlCIDarkBrown '26 - 30
: xlCIDarkTurquoise: xlCISeaBlue: xlCISkyBlue: xlCILightTurquoise2: xlCILightGreen '31 - 35
: xlCILightYellow: xlCIPaleBlue: xlCIRose: xlCILavender: xlCITan '36 - 40
: xlCILightBlue: xlCIAqua: xlCILime: xlCIGold: xlCILightOrange '41 - 45
: xlCIOrange: xlCIBlueGray: xlCIGray40: xlCIDarkTeal: xlCISeaGreen '46 - 50
: xlCIDarkGreen: xlCIGreenBrown: xlCIBrown: xlCIDarkPink2: xlCIIndigo '51 - 55
: xlCIGray80 '56
End Enum
Private xlFC(1 To 56) As Boolean 'Font color: True is black, False is white
#End If

Sub sbRegattaFlightPlan()
'Performs a simple Monte Carlo simulation to create a regatta flight plan.
'Source (EN): http://www.sulprobil.de/sbregattaflightplan_en/
'Source (DE): http://www.berndplumhoff.de/sbregattaflightplan_de/
'(C) (P) by Bernd Plumhoff 07-Jan-2023 PB V0.3

Dim i                       As Long
Dim j                       As Long
Dim k                       As Long
Dim m                       As Long
Dim lAdjacentFlights        As Long
Dim lBestSailorInBoat       As Long
Dim lBestSailorMeetSailor   As Long
Dim lBoatCount              As Long
Dim lFlightCount            As Long
Dim lLowestAdjacentFlights  As Long
Dim lMaxSailorInBoat        As Long
Dim lMaxSailorMeetSailor    As Long
Dim lSailorIndex            As Long
Dim lSailorCount            As Long
Dim lSimulationCount        As Long
Dim state                   As SystemState

With Application.WorksheetFunction

'Initialize
Set state = New SystemState
Cells.Interior.Pattern = xlNone
Cells.Interior.TintAndShade = 0
Cells.Interior.PatternTintAndShade = 0
Cells.Font.ColorIndex = xlAutomatic
Cells.Font.TintAndShade = 0

#If I_Want_Colors Then
For i = 1 To 56
    xlFC(i) = True
Next i
xlFC(xlCIBlack) = False: xlFC(xlCIRed) = False: xlFC(xlCIBlue) = False
xlFC(xlCIDarkRed) = False: xlFC(xlCIGreen) = False: xlFC(xlCIDarkBlue) = False
xlFC(xlCIDarkYellow) = False: xlFC(xlCIViolet) = False: xlFC(xlCIDarkPurple) = False
xlFC(xlCILightBrown) = False: xlFC(xlCIDarkPink) = False: xlFC(xlCIDarkBrown) = False
xlFC(xlCISeaBlue) = False: xlFC(xlCIBlueGray) = False: xlFC(xlCIDarkTeal) = False
xlFC(xlCIDarkGreen) = False: xlFC(xlCIGreenBrown) = False: xlFC(xlCIIndigo) = False
xlFC(xlCIGray80) = False
#End If

Randomize
i = Range("Sailors").Row + 1
Do While Not IsEmpty(wsI.Cells(i + lSailorCount, 1))
    lSailorCount = lSailorCount + 1
Loop
ReDim sSailor(1 To lSailorCount) As String
i = Range("Sailors").Row
j = 1
Do While Not IsEmpty(wsI.Cells(i + j, 1))
    sSailor(j) = wsI.Cells(i + j, 1)
    #If I_Want_Colors Then
    k = (j Mod 56) + 1
    wsI.Cells(i + j, 1).Interior.ColorIndex = k
    If xlFC(k) Then
        wsI.Cells(i + j, 1).Font.ColorIndex = xlCIBlack
    Else
        wsI.Cells(i + j, 1).Font.ColorIndex = xlCIWhite
    End If
    #End If
    j = j + 1
Loop
 
lBoatCount = Range("Boats")
lFlightCount = Range("Flights")
lSimulationCount = Range("Simulations")
lBestSailorMeetSailor = lSailorCount
lBestSailorInBoat = lBoatCount
lLowestAdjacentFlights = lFlightCount * lSailorCount

If lFlightCount * lBoatCount Mod lSailorCount <> 0 Then
    Call MsgBox("Number of flights" & vbCrLf & "times number of boats" & vbCrLf & _
        "needs to be divisible" & vbCrLf & "by number of sailors!", vbOKOnly, "Error")
    Exit Sub
End If
If lBoatCount > lSailorCount Then
    Call MsgBox("Number of boats" & vbCrLf & "needs to be less or equal" & _
        vbCrLf & "to number of sailors!", vbOKOnly, "Error")
    Exit Sub
End If

Range("D:XFD").EntireColumn.Delete

ReDim lBestBoatInFlight(1 To lBoatCount, 1 To lFlightCount) As Long
For i = 1 To lSimulationCount
    ReDim lSailorInBoat(1 To lSailorCount, 1 To lBoatCount) As Long
    ReDim lSailorMeetSailor(1 To lSailorCount, 1 To lSailorCount) As Long
    ReDim lBoatInFlight(1 To lBoatCount, 1 To lFlightCount) As Long
    lAdjacentFlights = 0
    For j = 1 To lFlightCount
        ReDim lBoat(1 To lBoatCount) As Long
        For k = 1 To lBoatCount
            If lSailorIndex = 0 Then
                ReDim vSailor(1 To lSailorCount) As Variant
                vSailor = VBUniqRandInt(lSailorCount, lSailorCount)
                lSailorIndex = 1
            End If
            lBoat(k) = vSailor(lSailorIndex)
            lBoatInFlight(k, j) = vSailor(lSailorIndex)
            For m = 1 To k - 1
                lSailorMeetSailor(lBoat(k), lBoat(m)) = _
                    lSailorMeetSailor(lBoat(k), lBoat(m)) + 1
                lSailorMeetSailor(lBoat(m), lBoat(k)) = _
                    lSailorMeetSailor(lBoat(m), lBoat(k)) + 1
            Next m
            If j > 1 Then
                For m = 1 To lBoatCount
                    If lBoatInFlight(k, j) = lBoatInFlight(m, j - 1) Then
                        lAdjacentFlights = lAdjacentFlights + 1
                    End If
                Next m
            End If
            lSailorInBoat(vSailor(lSailorIndex), k) = _
                lSailorInBoat(vSailor(lSailorIndex), k) + 1
            lSailorIndex = (lSailorIndex + 1) Mod (lSailorCount + 1)
        Next k
    Next j
    lMaxSailorMeetSailor = 0
    For j = 1 To lSailorCount - 1
        For m = j + 1 To lSailorCount
            If lMaxSailorMeetSailor < lSailorMeetSailor(j, m) Then
                lMaxSailorMeetSailor = lSailorMeetSailor(j, m)
            End If
        Next m
    Next j
    lMaxSailorInBoat = 0
    For j = 1 To lSailorCount
        For m = 1 To lBoatCount
            If lMaxSailorInBoat < lSailorInBoat(j, m) Then
                lMaxSailorInBoat = lSailorInBoat(j, m)
            End If
        Next m
    Next j
    If lBestSailorMeetSailor + lBestSailorInBoat + lLowestAdjacentFlights > _
        lMaxSailorMeetSailor + lMaxSailorInBoat + lAdjacentFlights Then
        For j = 1 To lBoatCount
            For m = 1 To lFlightCount
                lBestBoatInFlight(j, m) = lBoatInFlight(j, m)
            Next m
        Next j
        lBestSailorMeetSailor = lMaxSailorMeetSailor
        lBestSailorInBoat = lMaxSailorInBoat
        lLowestAdjacentFlights = lAdjacentFlights
    End If
Next i

For m = 1 To lFlightCount
    wsI.Cells(1, 4 + m) = "Flight " & m
Next m
For j = 1 To lBoatCount
    wsI.Cells(1 + j, 4) = "Boat " & j
    For m = 1 To lFlightCount
        wsI.Cells(1 + j, 4 + m) = sSailor(lBestBoatInFlight(j, m))
        #If I_Want_Colors Then
        k = (lBestBoatInFlight(j, m) Mod 56) + 1
        wsI.Cells(1 + j, 4 + m).Interior.ColorIndex = k
        If xlFC(k) Then
            wsI.Cells(1 + j, 4 + m).Font.ColorIndex = xlCIBlack
        Else
            wsI.Cells(1 + j, 4 + m).Font.ColorIndex = xlCIWhite
        End If
        #End If
    Next m
Next j

wsI.Cells(j + 1, 4) = "Maximal meet of sailor pairs"
wsI.Cells(j + 1, 5) = lBestSailorMeetSailor
wsI.Cells(j + 2, 4) = "Maximal repetition of boat per sailor"
wsI.Cells(j + 2, 5) = lBestSailorInBoat
wsI.Cells(j + 3, 4) = "Number of sailors with adjacent flights"
wsI.Cells(j + 3, 5) = lLowestAdjacentFlights
Range("D:XFD").EntireColumn.AutoFit

End With

End Sub