Sub Test()
Dim objTable As Table
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim a As String
Dim b As String
Dim c As String
 
' Partie 1 : Récupérer les valeurs du tableau Word sans les 2 derniers caractères bizarres
Set objTable = ActiveDocument.Tables(1)
 
a1 = Len(Mid(objTable.Cell(1, 1), 7, 25)) - 2
a2 = Mid(objTable.Cell(1, 1), 7, a1)
 
b1 = Len(Mid(objTable.Cell(1, 2), 10, 25)) - 2
b2 = Mid(objTable.Cell(1, 2), 10, b1)
 
c1 = Len(Mid(objTable.Cell(1, 3), 7, 25)) - 2
c2 = Mid(objTable.Cell(1, 3), 7, c1)
 
'Partie 2 : Création excel
    Set xlApp = CreateObject("Excel.Application" )
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets.Add
 
'Partie 3 : coller les valeurs dans les cellules de Excel
    xlSheet.Cells(1, 1) = a2
    xlSheet.Cells(1, 2) = b2
    xlSheet.Cells(1, 3) = c2
     
xlApp.Visible = True
End Sub

Set xlApp = CreateObject("Excel.Application" )
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Open("D:\Mes Documents\Excel\Toto.xls" )
Set xlSheet = xlBook.Sheets("Feuil1" )

Sub WB_Open()
dim MyBook As Workbook
dim Myname As String, MyPath As String
dim Win As Window
dim IsOpen As Boolean
 
    Myname = "Mon_Fichier.xls"
    MyPath = "c:\Mon_Dossier\" 'or any other path
 
    for each Win In Windows
        if Win.Caption = Myname then
            Win.Activate
            IsOpen = true
            Exit for
        end if
    next Win
    if Not IsOpen then workbooks.Open (MyPath & Myname)
    set MyBook = activeworkbook
end Sub

Sub Test2()
Dim Chemin$, Wbk As Workbook
 
Chemin = "D:\Mes Documents\Excel\ToTo.xls"
On Error Resume Next
 
Workbooks(Dir$(Chemin)).Activate
If Err <> 0 Then
Err.Clear
Workbooks.Open Chemin
End If
Set Wbk = Workbooks(Dir$(Chemin))
MsgBox Wbk.Name
'etc.
End Sub

J'ai touvé un autre code
Citation :
 
Sub Test2()
Dim Chemin$, Wbk As Workbook
 
Chemin = "D:\Mes Documents\Excel\ToTo.xls"
On Error Resume Next
 
Workbooks(Dir$(Chemin)).Activate
If Err <> 0 Then
Err.Clear
Workbooks.Open Chemin
End If
Set Wbk = Workbooks(Dir$(Chemin))
MsgBox Wbk.Name
'etc.
End Sub
 
 
 
Il fonctionne à merveille intégré dans Excel mais je n'arrive pas à le faire fonctionner dans Word    
Il y a certainement plein de variable à rajouter comme CreateObject("Excel.Application" ) mais je ne suis pas assez bon en VBA  

Sub Test()
Dim a As String
Dim objExcel, objClasseur
Set objExcel = CreateObject("Excel.Application" )
 
' Controle si le fichier Toto.xls est ouvert et l'ouvre si necessaire
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
 
Dim strExcelFile, objFso, objFile
strExcelFile = "D:\Mes Documents\Excel\Toto.xls"
Set objFso = CreateObject("Scripting.FileSystemObject" )
 
On Error Resume Next
Set objFile = objFso.OpenTextFile(strExcelFile, ForAppending, TristateFalse)
 
If Err.Number <> 0 Then
MsgBox "Le fichier est déjà ouvert" & vbCrLf & Err.Number & vbCrLf _
           & Err.Source & vbCrLf & Err.Description: Err.Clear
          ' Que mettre ici pour aciver le fichier "Toto.xls" déjà ouvert ?
           
 Else
   MsgBox "Le fichier n'est pas ouvert"
      objFile.Close
      Set objClasseur = objExcel.Workbooks.Open(strExcelFile)
   'objExcel.DisplayAlerts = False
   objExcel.Application.Visible = True 'False
   'MsgBox "fichier " & strExcelFile & " ouvert"
   'objExcel.Quit
   
End If
 
' Partie 2 : Récupérer les valeurs du tableau Word sans les 2 derniers caractères bizarres
Set objTable = ActiveDocument.Tables(1)
a1 = Len(Mid(objTable.Cell(1, 1), 7, 25)) - 2
a2 = Mid(objTable.Cell(1, 1), 7, a1)
 
' partie 3 : Lance la macro "Macro1" de Excel
objExcel.Run ("Macro1" ) 'lance la macro de Excel
'objExcel.Cells(1, 1) = a2
' que mettre pour transferer la variable a2 dans la macro "Macro1" de Excel ?
 
'MsgBox a1 & " - " & a2
 
Set objExcel = Nothing
Set objClasseur = Nothing
Set objFile = Nothing
Set objFso = Nothing
End Sub

....
xlApp.Workbooks.Open ("C:\Transfert\MonFichier.xls" )
         
        xlApp.Workbooks("MonFichier.xls" ).Sheets("Feuil1" ).Cells(1, 1) = a2  
....