Extraction de données dans plusieurs fichiers Word par VBA

Bonjour à tous et merci d'avance pour votre temps consacré a ma demande,

Afin de pouvoir établir une nouvelle base de donnée, je dois extraire les données de plusieurs fichiers Word (Adresse du fichier en colonne R).

Dans les fichier Word, les données sont dans 2 colonnes (Données en jaune et en bleu) donc en verticale.

Une fois les données jaunes copiées, elles doivent s'insérer dans la ligne correspondante au fichier, en colonne AF - BD, Pour les données bleues BF - CD.

Il se peut qu'il y aient des infos manquantes a la source, alors laisser la cellule de destination vide.

J'espère avoir tout expliqué!

Pouvez-vous m'aider?

Je n'ai pas une grande expérience en Macro et je ne sais pas ou commencer.

J'avance dans le vide!

Sub Extract_Eval()

    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim Chemin As String
    Dim NomFi As String
    Dim WApp As Object, WDoc As Object, WSel As Object
    Dim I As Integer
    Dim n%

    Set WApp = CreateObject("Word.Application")
    WApp.Visible = False

      For I = 2 To DerniereLigne
                If Wb.Range("Eval environ") & Ws.Range("D" & I).Value = "XOui" Then
                Application.ScreenUpdating = False
                Set Wb = ThisWorkbook
                Set Ws = Wb.Sheets("Eval environ")
                sChemin = Ws.Range("R" & I) & "\"
                sNomFichier = Dir(Ws.Range("T" & I) & ".docx")
                  Set WDoc = WApp.Documents.Open(Chemin & NomFi)

'le document word devrait s'ouvrir....mais rien!

                      Else: MsgBox "Le fichier " & Ws.Range("T" & I) & " n'a pas été trouvé"
                End If
    Next I
End Sub

Cordialement et encore Merci d'avance

Bonsir

Je ne suis pas un grand spécialiste de la communication entre Excel et Word donc si quelqu'un trouve mieux je ne serai pas vexer

En attendant voici une proposition qui pour ce que j'ai pu tester fonctionne. Pour les tests j'ai modifié les cellule R2 et T2. J'ai mis la boucle For i / Next i en commentaire pour ne tester qu'un seul fichier.

Bonjour yal_excel,

Un GRAND MERCI, pour ce travail, après quelques adaptations sur mon environnement, ça fonctionne très bien.

Avec mes plus amicales remerciement et salutations

Andreas

Bonjour Andreas

Content que cela fonctionne et merci pour le retour

Voici le code final:

Sub copieTableauWordVersExcel()
'nécéssite d'activer la référence Microsoft Word xx.x Object Library
Application.ScreenUpdating = False
  Dim WordApp As Word.Application
  Dim WordDoc As Word.Document
  Dim docWord As String
  Dim chemin As String
  Dim tbW1(), tbW2()
  Dim i%, dlE%, dlW%
  Dim rng1 As Range

  Set WordApp = CreateObject("Word.Application") 'creation session Word
  WordApp.Visible = True 'pour que word reste masqué pendant l'opération

  dlE = Sheets("Eval environ").Cells(Rows.Count, 18).End(xlUp).Row
  Set rng1 = Sheets("Eval environ").Range("A2:CD" & dlE)
  For i = 2 To dlE ' Décommenter pour traiter toutes les lignes
    If rng1.Cells(i, 4) = "XOUI" Then
      chemin = rng1.Cells(i, 18).Value
      docWord = rng1.Cells(i, 20).Value
      Set WordDoc = WordApp.Documents.Open(chemin & docWord) 'ouverture du fichier Word
      WordDoc.Tables(3).Range.Copy 'copie du tableau Word

      Sheets("tmp").Activate
      With Sheets("tmp")
        .Cells.Delete
        .Range("A1").Select
        .Paste 'collage des données dans Excel
        WordDoc.Close False 'ferme le document Word sans sauvegarde
        dlW = .Cells(Rows.Count, 42).End(xlUp).Row
        tbW1 = .Range("AP16:AP" & dlW).Value2
        tbW2 = .Range("AR16:AR" & dlW).Value2
      End With
      Sheets("Eval environ").Activate
        rng1.Range(Cells(i, 31), Cells(i, 86)) = Application.Transpose(tbW1)
        rng1.Range(Cells(i, 76), Cells(i, 122)) = Application.Transpose(tbW2)

    End If
  Next i ' Décommenter pour traiter toutes les lignes
  WordApp.Quit 'ferme l'application Word

Application.ScreenUpdating = False
End Sub

Encore un grand MERCI

Andreas