Word vba - word vers excel [resolu]

Sub Signet_WORD_vers_Cellule_XL()
Dim appWord As Object, Doc As Object, strFich$
'Attention:=> CHANGER Chemin et nom du fichier WORD
strFich = "C:\Users\STAPLE1600\Documents\tests\test.docx"
Set appWord = CreateObject("Word.Application")
    With appWord
        .Visible = True
        Set Doc = .Documents.Open(strFich)
        With Doc
            ActiveSheet.[H1].Value = .Bookmarks("ville2").Range.Text
            .Save
        End With
        .Quit
    End With
End Sub

Sub Copie_Cellule_XL_vers_Signet_WORD()
Dim appWord As Object, Doc As Object, strFich$, BMRange As Object
'Attention:=> CHANGER Chemin et nom du fichier WORD
strFich = "C:\Users\STAPLE1600\Documents\tests\test.docx"
Set appWord = CreateObject("Word.Application")
    With appWord
        .Visible = True
        Set Doc = .Documents.Open(strFich)
            With Doc
                Set BMRange = .Bookmarks("ville2").Range
                BMRange.Text = ActiveSheet.[I8]
                .Bookmarks.Add "ville2", BMRange
                .Save
            End With
        .Quit
    End With
End Sub

Sub SignetsWord_Excel()
Dim xlApp As Excel.Application, xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet, BMRange As Word.Range, strFich$
'Attention:=> CHANGER Chemin et nom du fichier EXCEL
strFich = "C:\Users\STAPLE1600\Documents\tests\testA.xlsx"
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(strFich)
Set xlSheet = xlBook.Sheets(1) 'ici 1ère feuille du classeur
    xlSheet.Range("H1") = ActiveDocument.Bookmarks("ville2").Range.Text
    Set BMRange = ActiveDocument.Bookmarks("ville3").Range
    BMRange.Text = xlSheet.Range("I8")
    ActiveDocument.Bookmarks.Add "ville3", BMRange
    xlBook.Close SaveChanges:=True
    xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End Sub