XL 2019 Création aléatoire planning

Sub Tirage()
Dim personnes, ub%, deb As Range, dates As Range, P1P2(), n%, i%, j%, mini%, maxi%, r%
personnes = Array("HA", "JB", "LCB", "SD", "LE", "MEK", "MK", "MLM", "SM", "LP", "LRL", "BU", "EL", "RC", "TB", "CM", "ET")
ub = UBound(personnes)
Set deb = [b2]
While Application.Count(deb.EntireColumn)
    Set dates = deb.EntireColumn.SpecialCells(xlCellTypeConstants, 1)
    ReDim P1P2(1 To 2, 0 To ub) 'RAZ du tableau auxiliaire
    n = 0
    For i = 1 To dates.Count
        For j = 2 To 3
            If dates(i, j).Interior.Color <> vbBlack Then n = n + 1
    Next j, i
    mini = Int(n / (ub + 1)) 'minimum pour chaque personne
    maxi = Application.RoundUp(n / (ub + 1), 0) 'maximum pour chaque personne
    For i = 1 To dates.Count
        For j = 2 To 3
            If dates(i, j).Interior.Color <> vbBlack Then
                n = IIf(Application.Sum(P1P2) < mini * (ub + 1), mini, maxi)
                Do
                    r = Application.RandBetween(0, ub)
                    If P1P2(j - 1, r) + P1P2(4 - j, r) < n Then _
                        If P1P2(j - 1, r) < P1P2(4 - j, r) + 1 Then _
                            P1P2(j - 1, r) = P1P2(j - 1, r) + 1: dates(i, j) = personnes(r): Exit Do
                Loop
            End If
    Next j, i
    Set deb = deb.Offset(, 4) 'tableau suivant
Wend
End Sub

Sub Ajout_mois()
Dim deb As Range, mois%, annee%, Paques As Date, LundiPaques$, Ascension$, LundiPentecote$, feries, i&, dat As Date, n&, fer As Range, sem%, lig&

Set deb = Cells(1, Columns.Count).End(xlToLeft) 'dernier tableau
mois = Month(CDate(deb) + 31): annee = Year(CDate(deb) + 31)
Paques = Evaluate("DOLLAR((""4/""&" & annee & ")/7+MOD(19*MOD(" & annee & ",19)-7,30)*14%,)*7-6")
LundiPaques = Format(Paques + 1, "d/m")
Ascension = Format(Paques + 39, "d/m")
LundiPentecote = Format(Paques + 50, "d/m")
feries = Array("1/1", "1/5", "8/5", "14/7", "15/8", "1/11", "11/11", "25/12", LundiPaques, Ascension, LundiPentecote)

Application.ScreenUpdating = False
deb.MergeArea.Copy deb(1, 5) '1ère ligne
deb(2).Resize(, 3).Copy deb(2, 5) '2ème ligne
Set deb = deb(3, 5) 'cellule de la 1ère date
deb(1, 0).ColumnWidth = 10: deb(1, 2).Resize(, 2).ColumnWidth = 28 'lageurs des colonnes
deb.EntireColumn.Resize(, 3).HorizontalAlignment = xlCenter 'centrage
deb.EntireColumn.NumberFormat = "dddd d mmmm yyyy" 'format Date
For i = 1 To 31
    dat = DateSerial(annee, mois, i)
    If Month(dat) = mois And Weekday(dat, 2) < 6 Then
        n = n + 1
        deb(n) = dat
        deb(n).Resize(, 3).Borders.Weight = xlThin
        If IsNumeric(Application.Match(Format(dat, "d/m"), feries, 0)) Then _
            Set fer = Union(IIf(fer Is Nothing, deb(n, 2).Resize(, 2), fer), deb(n, 2).Resize(, 2))
        If Weekday(dat, 2) = 5 Then
            sem = sem + 1
            With Range(deb(lig + 1), deb(n)).Resize(, 3)
                .BorderAround Weight:=xlMedium
                If sem Mod 2 Then .Interior.Color = RGB(242, 242, 242) 'gris clair
            End With
            lig = n
        End If
    End If
Next i
If lig < n Then
    sem = sem + 1
    With Range(deb(lig + 1), deb(n)).Resize(, 3)
        .BorderAround Weight:=xlMedium
        If sem Mod 2 Then .Interior.Color = RGB(242, 242, 242) 'gris clair
    End With
End If
If Not fer Is Nothing Then fer.Interior.Color = vbBlack 'colore en noir les jours fériés
deb.EntireColumn.AutoFit 'ajustement largeur
End Sub

mois = Month(CDate(deb) + 31): annee = Year(CDate(deb) + 31): ThisWorkbook.Names.Add "An", annee 'nom défini An
ThisWorkbook.Names.Add "X", Evaluate("MOD(INT(An/400)-INT(An/100)+INT(8*(INT(An/100)+11)/25)+11*MOD(An,19)+11,30)") 'calcul intermédiaire
Paques = Evaluate("DATE(An,4,25-X-INT((8-19*X+MOD(An,19))/544)-MOD(MOD(-X-INT((8-19*X+MOD(An,19))/544),7)+MOD(MOD(2-2*MOD(INT(An/100),4),7)+MOD(An,100)+INT(MOD(An,100)/4),7),7))")

ub MAJ_12_mois()
Dim annee, n%
Do
    annee = Application.InputBox("Année :", "MAJ 12 mois", CStr(annee))
    If annee = False Or annee = "" Then Exit Sub
Loop While Not annee Like "####"
Application.ScreenUpdating = False
Columns("E").Resize(, Columns.Count - 4).Delete
[B3] = DateSerial(annee - 1, 12, 1) 'décembre de l'année précédente
For n = 1 To 12: Ajout_mois: Next
[B:E].Delete
Application.Goto [A1], True: [B1].Select 'cadrage
End Sub

Dim d As Object 'mémorise la variable
'----

Sub Tirage_optimal()
Dim t, plage As Range, ntirage%, mini%, n%, ecart%, tablo
t = Timer
Set plage = ActiveSheet.UsedRange.Offset(1)
ntirage = 100 'modifiable
mini = 50
Application.ScreenUpdating = False
For n = 1 To ntirage
    Tirage
    ecart = Application.Max(d.items) - Application.Min(d.items)
    If ecart < mini Then
        mini = ecart
        tablo = plage 'mémorise
    End If
Next
 plage = tablo 'restitution
Application.ScreenUpdating = True
MsgBox ntirage & " tirages effectués en " & Format(Timer - t, "0.00 \sec") & vbLf & vbLf & "Ecart obtenu " & mini, , "Tirage optimal"
End Sub