Microsoft 365 Générateur de lettres personnalisées à partir d'une liste

Sub Lettres_PDF()
Dim t, chemin$, F As Worksheet, i&
t = Timer
Application.ScreenUpdating = False
chemin = ThisWorkbook.Path & "\Dossier lettres\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création du sous-dossier
Set F = Sheets("Lettre personnalisee")
With Sheets("Liste").[A1].CurrentRegion
    For i = 2 To .Rows.Count
        F.Range("X4") = .Cells(i, 1) & " " & .Cells(i, 2)
        F.Range("Y5") = .Cells(i, 3)
        F.Range("Y6") = .Cells(i, 4)
        F.ExportAsFixedFormat xlTypePDF, chemin & F.Range("X4")
    Next
End With
MsgBox i - 2 & " fichiers PDF créés en " & Format(Timer - t, "0.00 \sec")
End Sub

Sub Lettres_PDF()
Dim t, chemin$, F As Worksheet, P As Range, i&, a()
t = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
chemin = ThisWorkbook.Path
Set F = Sheets("Lettre personnalisee")
Set P = Sheets("Liste").[A1].CurrentRegion
For i = 2 To P.Rows.Count
    F.Copy After:=Sheets(Sheets.Count) 'nouvelle feuille
    With ActiveSheet
        .Range("X4") = P(i, 1) & " " & P(i, 2)
        .Range("Y5") = P(i, 3)
        .Range("Y6") = P(i, 4)
        ReDim Preserve a(i - 2)
        a(i - 2) = .Name
    End With
Next
Sheets(a).Select 'toutes les feuilles créées sont sélectionnées
ActiveSheet.ExportAsFixedFormat xlTypePDF, chemin & "\Fichier PDF.pdf"
Sheets(a).Delete 'toutes les feuilles créées sont supprimées
P.Parent.Select
MsgBox i - 2 & " feuilles créées en " & Format(Timer - t, "0.0 \sec")
End Sub