Extraction données word vers Excel

Bonjour à tous.

Je sollicite votre aide pour terminer une macro VBA.

Le role de cette macro est d'extraire les données de tableaux word vers Excel.

J'ai écrit le code suivant grace à un tutoriel, mais il s'applique qu'aux tableaux de la première page du document Word et pas à l'ensemble des pages du document word. Le document word en question à 119 pages et j'aimerais que le code s'applique à toutes les pages. Il faudrait ecrire une boucle mais mes différentes tentatives ne donnent absolument rien.

Merci d'avance pour votre appui.

Sub extractData()

Dim wd As New Word.Application
Dim doc As Word.Document
Dim sh As Worksheet
Dim pg As Page

wd.Visible = True

Set doc = wd.Documents.Open(ActiveWorkbook.Path & "C:\Users\toeab\Desktop\Baseline Surveys (fr) en-US correct.docx")
Set tbls = doc.Tables
Set sh = ActiveSheet

Ir = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
For c = 1 To 5
sh.Cells(Ir, c).Value = Application.WorksheetFunction.Clean(tbls(2).Rows(c).Cells(2).Range.Text)
Next

For c = 1 To 5
sh.Cells(Ir, 5 + c).Value = Application.WorksheetFunction.Clean(tbls(3).Rows(c).Cells(2).Range.Text)
Next

For c = 1 To 13
sh.Cells(Ir, 10 + c).Value = Application.WorksheetFunction.Clean(tbls(4).Rows(c).Cells(2).Range.Text)
Next
sh.Cells(Ir, 24).Value = Application.WorksheetFunction.Clean(tbls(4).Rows(2).Cells(3).Range.Text)

End Sub

Bonjour,

Combien de tables avez-vous par page ?

S'il y en a 4 par page et si le nombre de lignes de vos tables correspond à ce que vous devez récupérer, il vous suffit de faire une boucle sur la collection Tables (tbls) et une boucle sur le nombre de lignes.

Bonjour,

J'ai 4 tables par pages et 119 pages. Effectivement je comprends qu'il faille faire une boucle, mais étant novice en VBA tous les tests que j'ai fait me donne une erreur "438".

Pourriez-vous m'aider pour cette boucle?

En vous remerciant d'avance.

Exemple d'une page en pièce jointe le document final contient 119 pages comme ça.

Cordialement.

Dans votre dernier tableau, vous avez des cellules fusionnées. Que voulez-vous récupérer avec ce code ?

For c = 1 To 13
sh.Cells(Ir, 10 + c).Value = Application.WorksheetFunction.Clean(tbls(4).Rows(c).Cells(2).Range.Text)
Next

Oui exactement la fréquence d'utilisation que je veux aussi extraire.
Cordialement

La question était : Lorsque vous avez des lignes de 2 ou 3 colonnes, dans les lignes à 3 colonnes, quelle cellule récupérez-vous ?

Bonsoir,

Enfait dans le tableau à 3 colonnes je récupè

re le nombre de foyers (Home) cellule 2 et la frequence cellule 3 mais uniquement sur la ligne (fireplace 3 stones).

Pour les 3 lignes en dessous (Ceramic fireplace, Improved fireplace, Gas fireplace) je ne recupere que le contenu de la cellule 2 (Home). Pour ces lignes pas besoin de la fréquence.

En pièce jointe le rendu du code sur une page mais qui ne s'applique pas à l'ensemble du document.

Merci

Option Explicit

Sub ExtractData()

Dim TableEnCours As Integer, NumeroTable As Integer, PageEnCours As Integer, Ir As Integer, C As Integer
Dim WdApp As New Word.Application, WdDoc As Word.Document, WdTables As Word.Tables, WdTable As Word.Table
Dim Sh As Worksheet

        Set Sh = ActiveSheet
        With Sh
             Ir = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        End With

        With WdApp
             .Visible = True
             Set WdDoc = .Documents.Open(ActiveWorkbook.Path & "\family-survey-form1.docx")
        End With

        With WdDoc
             Set WdTables = .Tables
             PageEnCours = 1

             For TableEnCours = 1 To WdTables.Count
                 Set WdTable = WdTables(TableEnCours)
                 If WdTable.Cell(1, 1).Range.Information(wdActiveEndPageNumber) > PageEnCours Then
                    PageEnCours = WdTable.Cell(1, 1).Range.Information(wdActiveEndPageNumber)
                    NumeroTable = 0
                    Ir = Ir + 1
                 End If
                 NumeroTable = NumeroTable + 1
                 Select Case NumeroTable
                        Case 2
                             For C = 1 To 5
                                 Sh.Cells(Ir, C).Value = Application.WorksheetFunction.Clean(WdTable.Cell(C, 2).Range.Text)
                             Next
                        Case 3
                             For C = 1 To 5
                                 Sh.Cells(Ir, 5 + C).Value = Application.WorksheetFunction.Clean(WdTable.Cell(C, 2).Range.Text)
                             Next
                        Case 4

                             For C = 1 To 13
                                 Sh.Cells(Ir, 10 + C).Value = Application.WorksheetFunction.Clean(WdTable.Cell(C, 2).Range.Text)
                             Next
                             Sh.Cells(Ir, 24).Value = Application.WorksheetFunction.Clean(WdTable.Cell(2, 3).Range.Text)
                 End Select
                 Set WdTable = Nothing
             Next TableEnCours

             .Close False

        End With

        WdApp.Quit

        MsgBox "Fin de l'import !", vbInformation

        Set WdTables = Nothing: Set WdDoc = Nothing

End Sub

Bonsoir Mr. Kergresse,

Je viens de tester le code, il marche à perfection.

Je vous en remercie énormément. Vous me ferez gagner un temps fou à l'avenir.

Excellente semaine à vous.

Cordialement