XL 2016 Optimisation code agenda

Sub Test()
    Agenda 2020, 12    'année puis mois
End Sub

Function Agenda(année, Mois)
Dim I As Long, col As Long, lig As Long, lig2 As Long, nbjour As Long
Dim derlig As Integer, dercol As Integer, j As Integer, difeuro As Long
Dim FetePren As Variant, Hdeb As Long, Hfin As Long
Application.DisplayAlerts = False: Application.ScreenUpdating = False

nbjour = Day(DateSerial(année, Mois + 1, 0))    ' te donne le nombre de jour dans le mois en parametre
If Weekday(DateSerial(année, 1, 1), vbMonday) > 4 Then difeuro = 1    ' 1 si semaine commence apres jeudi
With ActiveSheet
derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column

.Range(.Cells(1, 1), .Cells(derlig + 2, dercol + 2)).Clear
Hdeb = Worksheets("Paramètre").Range("C2").Value: Hfin = Worksheets("Paramètre").Range("C3").Value: lig = 2: col = 3
For I = 1 To nbjour
    .Cells(lig, col) = WorksheetFunction.Proper(Format(DateSerial(année, Mois, I), "dddd")) ' Marquage des jours (ligne 2)
    .Cells(lig, col).Font.Bold = True
    .Cells(lig, col).Font.Size = 14
    .Cells(lig + 1, col) = (Format(DateSerial(année, Mois, I), "dd" & " " & "mmmm" & " " & année))
    .Range(Cells(lig, col), Cells(lig + 1, col)).HorizontalAlignment = xlCenter
    .Cells(1, 3) = "Semaine " & " " & val(Format(DateSerial(année, Mois, 1), "WW", vbMonday)) - difeuro ' numero semaine
    .Cells(lig - 1, col) = IIf(.Cells(lig, col) Like "Lundi", "Semaine " & " " & val(Format(DateSerial(année, Mois, I), "WW", vbMonday)) - difeuro, "") ' numero semaine
    .Cells(lig - 1, col).Font.Bold = True
    .Cells(lig - 1, col).Font.Size = 18
col = col + 1
Next

derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
lig = 3: lig2 = 4: col = 1:
For I = Hdeb To Hfin
    .Cells(lig, col) = Hdeb
    .Cells(lig, col).Font.Bold = True
    .Cells(lig, col).Font.Size = 16
    .Range(Cells(lig, 1), Cells(lig + 1, 1)).MergeCells = True
    .Cells(lig, 1).VerticalAlignment = xlCenter
    .Cells(lig, 1).HorizontalAlignment = xlCenter
    .Range(Cells(lig, 2), Cells(lig, dercol + 1)).Borders(xlEdgeBottom).LineStyle = xlContinuous
    For j = 1 To (Hfin - Hdeb)
        .Cells(lig2, 2) = 30
        .Range(Cells(lig2, 2), Cells(lig2 + 1, 2)).MergeCells = True
        .Cells(lig2, 2).VerticalAlignment = xlCenter
        .Cells(lig2, 2).HorizontalAlignment = xlCenter
        .Range(Cells(lig2, 3), Cells(lig2, dercol + 1)).Borders(xlEdgeBottom).LineStyle = xlDot
    Next
lig = lig + 2: lig2 = lig2 + 2: Hdeb = Hdeb + 1
Next

.Rows("1").RowHeight = 25
derlig = .Range("A" & Rows.Count).End(xlUp).Row: dercol = .Cells(2, Columns.Count).End(xlToLeft).Column
    .Range(Cells(4, 3), Cells(derlig, 34)).Borders(xlInsideVertical).LineStyle = xlContinuous
    .Range("B1:AH3").Borders(xlInsideVertical).LineStyle = xlContinuous
    .Range(Cells(1, 3), Cells(1, 33)).Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Columns("A").ColumnWidth = 5
    .Columns("B").ColumnWidth = 3
    .Columns("C:AG").ColumnWidth = 30
    .Rows("4:" & derlig).RowHeight = 22
 
Select Case True
   Case .Cells(1, 4) Like "*Semaine*": Range("D1:J1,K1:Q1,R1:X1,Y1:AE1,AF1:AG1").MergeCells = True
   Range("D1,K1,R1,Y1,AF1").HorizontalAlignment = xlCenter
   Case .Cells(1, 5) Like "*Semaine*": Range("C1:D1,E1:K1,L1:R1,S1:Y1,Z1:AF1").MergeCells = True
   Range("C1,E1,L1,S1,Z1").HorizontalAlignment = xlCenter
   Case .Cells(1, 6) Like "*Semaine*": Range("C1:E1,F1:L1,M1:S1,T1:Z1,AA1:AG1").MergeCells = True
   Range("C1,F1,M1,T1,AA1").HorizontalAlignment = xlCenter

    Do While Range("FichFetes!C1").Offset(x, 0) <> ""
        If Range("FichFetes!A1").Offset(x, 0) = I And Range("FichFetes!B1").Offset(x, 0) = Mois Then
            FetePren = FetePren & Range("FichFetes!C1").Offset(x, 0) & ", "
        End If
    x = x + 1
    Loop
    If FetePren <> "" Then
        .Cells(derlig + 2, col) = Chr(10) & Mid(FetePren, 1, Len(FetePren) - 2) & Chr(10) & Chr(10)
    Else
        .Cells(derlig + 2, col) = ""
    End If
     
col = col + 1
Next
End With
With ActiveWindow: .SplitColumn = 2: .SplitRow = 3: End With: ActiveWindow.FreezePanes = True
Call Actu_jour(année, Mois)
End Function

Function Actu_jour(année, Mois)


lig = 2: col = 3
With ActiveSheet
derlig = .Range("A" & Rows.Count).End(xlUp).Row
dercol = .Cells(4, Columns.Count).End(xlToLeft).Column

.Range(Cells(lig, 3), Cells(derlig + 1, dercol)).Interior.Color = xlNone
For I = 1 To nbjour
    .Range(Cells(lig, col), Cells(lig + 1, col)).Interior.ColorIndex = 34 'Coloriage jours
    .Range(Cells(lig - 1, col), Cells(lig - 1, dercol + 1)).Interior.ColorIndex = 36 'Coloriage n°semaine
If Weekday(DateSerial(année, Mois, I), vbMonday) > 6 Then .Range(Cells(lig, col), Cells(derlig, col)).Interior.ColorIndex = 34

If année = Year(Date) And Mois = Month(Date) And I = Day(Date) Then
    .Range(Cells(lig, col), Cells(lig + 1, col)).Interior.ColorIndex = 39 'Coloriage aujourd'hui
    ActiveWindow.ScrollColumn = I - 1
    .Cells(lig + 2, col).Select
End If

For j = 0 To UBound(Jférié)
    If CDate(Jférié(j) & année) = DateSerial(année, Mois, I) Then
        .Range(Cells(lig, col), Cells(derlig, col)).Interior.ColorIndex = 35 '  Interior.Color = vbGreen 'Coloriage férié
        Cells(lig, col).Interior.ColorIndex = 35 '  Interior.Color = vbGreen 'Coloriage férié
        Cells(lig + 2, col) = Jfériéstring(j)
        Cells(lig + 2, col).HorizontalAlignment = xlCenter
    End If
Next
   
For k = 0 To UBound(Jfete)
    If CDate(Jfete(k) & année) = DateSerial(année, Mois, I) Then
        .Range(Cells(lig, col), Cells(lig + 1, col)).Interior.ColorIndex = 35 '  Interior.Color = vbGreen 'Coloriage férié
        Cells(lig, col).Interior.ColorIndex = 35 '  Interior.Color = vbGreen 'Coloriage fête
        Cells(lig + 2, col) = Jfetestring(k)
        Cells(lig + 2, col).HorizontalAlignment = xlCenter
    End If
Next
    .Cells(derlig + 1, col) = "Fêtes à souhaiter" & " :  "
    .Cells(derlig + 1, col).Interior.ColorIndex = 36
    .Cells(derlig + 2, col).Interior.ColorIndex = 34
    .Cells(derlig + 1, col).Font.Bold = True
    .Cells(derlig + 1, col).Font.Size = 11
    .Rows(derlig + 1).RowHeight = 15
    .Rows(derlig + 2).RowHeight = 60
col = col + 1
Next
End With
End Function