Ecrire dans une cellule de plusieurs fichiers Excel

Sub BoucleDir()
Dim Chemin As String, Fichier As String, Extens As String, Wb As Workbook
    Chemin = "C:\Users\Desktop\" 'ICI ADAPTER LE CHEMIN
    Extens = "*.xls*"
    Fichier = Dir(Chemin & Extens)
    If Fichier <> vbNullString Then
        Do
            Set Wb = Workbooks.Open(Chemin & Fichier)
            With Wb.Worksheets(Wb.Name)
                .Range("A1").Value = "UN MEME MOT" 'ICI ADAPTER A1 et "UN MEME MOT"
            End With
            Wb.Close True
            Fichier = Dir
        Loop While Fichier <> vbNullString
    End If
End Sub