XL 2010 400 fichier Word à insérer sur Excel

adel.benmahmoud79 à dit:

Merci beaucoup
Je vais l’essayer

Cliquez pour agrandir...

Staple1600 à dit:

Bonjour @adel.benmahmoud79 , le fil

@adel.benmahmoud79
En guise d'exemple
Test OK sur Office 365 avec des fichiers Word simples.
Ici pour le test, 5 fichiers Word d'une seule page, contenant un tableau de 5 lignes sur 3 colonnes

Spoiler: Cliquez pour voir le code VBA

Code:

Sub Copie_TableauxWord_vers_Excel()
'Déclarations variables
Dim ws As Worksheet, str_Path$, Nom_Fic$, wordApp As Object, wordDoc As Object
Dim table As Object, row As Object, cell As Object, lig&, xCol&
 
Set ws = ThisWorkbook.Sheets(1)
str_Path = "C:\Users\STAPLE\Documents\XLD_TESTS\" '<- chemin à adapter

lig = 1
 
On Error Resume Next
Set wordApp = CreateObject("Word.Application")
'boucle sur les *.docx
Nom_Fic = Dir(str_Path & "*.docx")
Do While Nom_Fic <> ""
    Set wordDoc = wordApp.Documents.Open(str_Path & Nom_Fic)
    For Each table In wordDoc.Tables
        xCol = 1
        For Each row In table.Rows
            For Each cell In row.Cells
                ws.Cells(lig, xCol).Value = CleanText(cell.Range.text)
                xCol = xCol + 1
            Next cell
            lig = lig + 1
            xCol = 1
        Next row
    Next table
    wordDoc.Close False
    Nom_Fic = Dir
Loop
wordApp.Quit
Set wordApp = Nothing
MsgBox "Recopie terminée.", vbInformation, "Import Word"
End Sub
Function CleanText(text As String) As String
CleanText = Replace(Replace(text, Chr(13), ""), Chr(7), "")
End Function

Voici le résultat obtenu dans Excel.
Regarde la pièce jointe 1215493
PS: j'ai ajouté les couleurs manuellement pour distinguer les 5 fichiers Word.

EDITION: Version modifiée pour récupérer le nom des fichiers en colonne A, les données à partir de la colonne B

Spoiler: Cliquez pour voir le code VBA

VB:

Sub TableauxWord_vers_Excel()
'Déclarations variables
Dim ws As Worksheet, str_Path$, Nom_Fic$, wordApp As Object, wordDoc As Object
Dim table As Object, row As Object, cell As Object, lig&, xCol&
Set ws = ThisWorkbook.Sheets(1)
str_Path = "C:\Users\STAPLE\Documents\XLD_TESTS\" '<- chemin à adapter
lig = 1
On Error Resume Next
Set wordApp = CreateObject("Word.Application")
'boucle sur les *.docx
Nom_Fic = Dir(str_Path & "*.docx")
Do While Nom_Fic <> ""
    ws.Cells(lig, 1).Value = Nom_Fic
    Set wordDoc = wordApp.Documents.Open(str_Path & Nom_Fic)
    For Each table In wordDoc.Tables
        xCol = 2
        For Each row In table.Rows
            For Each cell In row.Cells
                ws.Cells(lig, xCol).Value = CleanText(cell.Range.text)
                xCol = xCol + 1
            Next cell
            lig = lig + 1
            xCol = 2
        Next row
    Next table
    wordDoc.Close False
    Nom_Fic = Dir
Loop
wordApp.Quit
Set wordApp = Nothing
MsgBox "Recopie terminée.", vbInformation, "Import Word"
End Sub
Function CleanText(text As String) As String
    CleanText = Replace(Replace(text, Chr(13), ""), Chr(7), "")
End Function

Cliquez pour agrandir...