Sub transfer()
Dim WordDoc As Word.Document
Dim Tableau As Word.Table
Dim Fichier As Variant
Dim Lig&
Fichier = Application.GetOpenFilename("Text Files (*.doc*), *.doc*")
If Fichier = False Then Exit Sub
Set WordDoc = GetObject(Fichier)
Lig& = 1
For Each Tableau In WordDoc.Tables
If UCase(Left(Tableau.Cell(1, 1), 5)) = "INDEX" Then
Tableau.Range.Copy
Range("A" & Lig& & "").Select
ActiveSheet.Paste
Lig& = Lig& + Tableau.Range.Rows.Count + 1
End If
Next Tableau
Application.CutCopyMode = False
WordDoc.Close
Set WordDoc = Nothing
[a1].Select
End Sub