Modification code macro selon utilisateur

Dim chemin As String
chemin = CreateObject("WScript.Shell").specialFolders("Desktop")

Sub ecran()

Dim WdApp As Object, WdDoc As Object

With Sheets("Echéancier")
    PCE = .Range("G6")
    Nom = .Range("B2")
    
End With

Chemin = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE & "\" & Nom

With Sheets("Copie").Range("A1:J170")
    .Copy
End With

If Dir("Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours\" & "\" & Nom & " " & PCE, vbDirectory) = "" Then
MsgBox "Le dossier numérique de " & Nom & " " & PCE & " n'a pas été créé. Veuillez le créer puis recommencer", vbCritical, "Attention"
Exit Sub
End If

'Lancer une instance Word
Set WdApp = CreateObject("Word.Application")
'Rendre Word visible
WdApp.Visible = True
'Ouvrir le document Word
Set WdDoc = WdApp.Documents.Open("C:\Users\bxxxxx\Desktop" & "\" & "Masque.doc") 'indiquer le chemin du fichier modèle
With WdDoc
'Copie de la feuille 4 Excel
    'Sheets(4).Copy
'Coller la feuille dans Word
    For Each i In Sheets("Copie").Shapes
    i.Copy
    WdApp.Selection.Paste
    Next
'Annuler le mode couper/copier
    Application.CutCopyMode = False
    
   .SaveAs Filename:=Chemin
    .Close True
End With

WdApp.Quit
Set WdDoc = Nothing
Set WdApp = Nothing

ActiveSheet.Shapes("MonBouton2").Visible = True
Application.OnTime Now + TimeValue("00:00:02"), "EffacerMessage2"
End Sub
Sub EffacerMessage2()
ActiveSheet.Shapes("MonBouton2").Visible = False
End Sub

'Ouvrir le document Word 
Set WdDoc = WdApp.Documents.Open("C:\Users\bxxxxx\Desktop" & "\" & "Masque.doc") 'indiquer le chemin du fichier modèle

Dim chemin As String
chemin = CreateObject("WScript.Shell").specialFolders("Desktop")
Set WdDoc = WdApp.Documents.Open(chemin & "\" & "Masque.doc")

CreateObject("WScript.Shell").specialFolders("Desktop")