Tableaux word vers Excel

Bonjour,

Je souhaiterais bâtir une macro permettant de copier les tables dont le titre contient le mot clé "liste" disséminées à divers endroits d'un document word, vers une feuille excel, les unes à la suite des autres.

Toutes ces tables ont un format identique (4 colonnes).

Certaines cellules de ces tables contiennent des retours chariot et des listes à puce, qu'il me faut conserver lors de la copie vers excel.

J'ai trouvé des bouts de code à gauche et à droite sur internet, mais soit je ne parviens pas à limiter l'extraction aux tables voulues soit le texte est copié en brut sans respect des retours chariot et des listes à puce. Je suis donc toujours bloqué sur le ligne de départ.

Je vous remercie par avance pour votre aide.

Bonjour,

Auriez vous le fichier Word en question ? Merci

Bonjour Valc,

Je ne travaille pas pour la Nasa mais le contenu de mon word étant plus ou moins confidentiel, j'en ai fais une copie avec un contenu tout à fait quelconque.

Donc dans le fichier joint, l'idée serait de copier les tables 5, 7 et 8 car elles seules ont un titre contenant 'Liste".

Merci,

Bonjour,

Voici un premiers jet.

Pour que ça fonction il faut renseigner l'adresse du fichier Word et importer la référence Word Libraire

y dans VBA .

Merci Valc,

En réutilisant un autre code j'ai pu légèrement modifier le code pour pouvoir aller chercher le fichier word à utiliser.

Sub wrd()
    'necessite d'activer la reference microsoft Word xx.x Object Library

'--------------------------------------
'Détermination du fichier vecteur (programme)
    file_prog = ActiveWorkbook.Name
    file_prog_pth = ActiveWorkbook.Path

    Set X_prog = Workbooks(file_prog).Sheets(1)

    Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object
Dim i As Integer, 

ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)

    i = 2
    For Each unetable In WordDoc.Tables()
          letitre = unetable.Title

          If letitre <> "" Then

            X_prog.Cells(i, 1) = unetable.Columns(1).Cells(2)
            X_prog.Cells(i, 2) = unetable.Columns(2).Cells(2)
            X_prog.Cells(i, 3) = unetable.Columns(3).Cells(2)
            X_prog.Cells(i, 4) = unetable.Columns(4).Cells(2)

            i = i + 1
        End If
    Next

    WordDoc.Close
        WordApp.Application.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End If

End Sub

On est d'accord que le code ne permet pas actuellement de conserver les retours chariots, puces,etc? Juste histoire de savoir si c'est chez moi que ça ne fonctionne pas

Par contre je me suis mal exprimé, je disais que toutes ces tables avaient un format identique. en fait elles ont toutes 4 colonnes mais peuvent avoir un nombre de ligne variable. Il est possible d'ajouter cette notion au code?

Cordialement,

re,

j'ai pu bidouiller le code pour qu'il s'adapte au nombre de ligne variable dans chaque table.

Sub wrd()
    'necessite d'activer la reference microsoft Word xx.x Object Library

'--------------------------------------
'Détermination du fichier vecteur (programme)
    file_prog = ActiveWorkbook.Name
    file_prog_pth = ActiveWorkbook.Path

    Set X_prog = Workbooks(file_prog).Sheets(1)

    Dim NDF As Variant
Dim WordApp As Object, WordDoc As Object
Dim i As Integer, j As Integer, u As Integer

ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename
    If Not NDF = False Then
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)

    For Each unetable In WordDoc.Tables()
          letitre = unetable.Title
          If letitre <> "" Then
            j = unetable.Rows.Count

            For u = 2 To j '6
            i = Range("A" & Rows.Count).End(xlUp).Row + 1
            X_prog.Cells(i, 1) = unetable.Columns(1).Cells(u)
            X_prog.Cells(i, 2) = unetable.Columns(2).Cells(u)
            X_prog.Cells(i, 3) = unetable.Columns(3).Cells(u)
            X_prog.Cells(i, 4) = unetable.Columns(4).Cells(u)
            Next u
          End If
    Next

    WordDoc.Close
        WordApp.Application.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
    End If

End Sub

Il ne reste "plus que" le problème des retours chariots, puces, etc à régler...

Bonjour,

Une solution est de passer par le presse-papier (Clipboard).

Le code (nettoyé) devient alors (rq : avec la bonne ref !) :

Sub wrd()   ' activer la réf MS Forms 2.0 Object Library
Dim NDF As Variant
Dim Feuil As Object, Ttk As DataObject
Dim WordApp As Object, WordDoc As Object, Tbl As Object
Dim lg As Integer, i As Integer, j As Integer

    ChDrive Left(ActiveWorkbook.Path, 1)
    ChDir ActiveWorkbook.Path
    NDF = Application.GetOpenFilename("Fichiers Word; *.doc, *.docx")
    If Not NDF = False Then
        Set Feuil = ActiveWorkbook.Sheets(1)
        Set WordApp = CreateObject("Word.Application")
        Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=True)
        Set Ttk = New DataObject
        For Each Tbl In WordDoc.Tables()
            If Tbl.Title <> "" Then
                lg = Feuil.Range("A" & Rows.Count).End(xlUp).Row + 1
                For i = 2 To Tbl.Rows.Count
                    For j = 1 To Tbl.Columns.Count
                        Tbl.cell(i, j).Range.Copy
                        Ttk.GetFromClipboard
                        Feuil.Cells(lg, j).Value = Ttk.GetText(1)
                    Next j
                    lg = lg + 1
                Next i
              End If
        Next Tbl
        WordDoc.Close
        WordApp.Application.Quit
        Set WordDoc = Nothing
        Set WordApp = Nothing
        Set Ttk = Nothing
        Set Feuil = Nothing
    End If
End Sub

Pierre

Bonjour Pierre,

Impec, ça tourne nikel.

Merci à toi et à Valc.

Bonsoir,

Finalement j'ai une erreur intermittente au niveau de Ttk.GetFromClipboard

Erreur d'exécution '-2147221040 (800401d0':

DataObject:GetFromClipboard Echec de OpenClipboard

Si vous avez une petite idée..

Merci

bon, j'ai essayé de jouer avec les OpenClipboard 0&, EmptyClipboard mais rien n'y fait. Des fois ça marche( c'est rare), des fois ça plante (très souvent)