Macro - Récupérer champs dans tables Word

Version imprimable

Bonjour à tous,

J'aurai besoin de petit coup de pouce pour un problème qui jusqu'alors est resté insoluble pour moi.

Je m'explique: j'ai créée un document Word "standart" constitué de plusieurs tables à l'intérieur desquelles il y a soit des champs de type liste déroulante soit des champs texte.

Mon objectif est de récupérer une partie des informations contenues dans ces tables: toutes les valeurs choisies dans les listes déroulantes et une partie des champs texte. (et ce pour 70 documents en gros)

Pour le moment, j'utilise cette macro basique et pas très pratique pour ce que je souhaite faire (les copier coller sur excel me font une mise en page pas terrible et je ne sais pas a priori combien de copier coller je vais devoir faire) :

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub Macro1()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
    Set WordApp = CreateObject("word.application")
    WordApp.Visible = False
    Set WordDoc = WordApp.Documents.Open("Mondocument")
    WordDoc.Tables().Rows().Cells().Range.Copy
    Range("").PasteSpecial xlPasteValues
    WordDoc.Close
    WordApp.Quit
End Sub

J'ai donc cherché à faire une macro plus "évoluée" et surtout plus adaptée mais pour le moment le résultat n'est pas concluant, j'aurai donc aimé savoir ce qui ne fonctionne pas dans ce code dont je me suis inspiré et que j'ai cherché à adapter à mon usage:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Sub ImportWord()
 
Dim Wd As Word.Application
Dim filename As String
Dim i As Byte
 
 'On affiche la boite de dialogue pour sélectionner le fichier
 
    filename = Application.GetOpenFilename("Fichier Word (*.docx*),*.docx*", 1, "Sélectionnez un document Word", "Ouvrir", False)
 
    'On vérifie qu'un fichier a été sélectionné
 
    If filename <> "" Then
        filename = LCase(filename)
        'et qu'il s'agit d'un document word
 
        If Right(filename, 3) = "doc" Or Right(filename, 4) = "docx" Then
 
            'Créer une instance de word
 
            Set Wd = New Word.Application
 
            With Wd
 
                'Empêche Word de s'afficher à l'ouverture
 
                .Visible = False
 
                'Ouverture du document
 
                .Documents.Open (filename)
 
                'Dévérouillage du document
 
                ActiveDocument.Protect Type:=wdNoProtection
 
                'Parcours de tous les champs de toutes les tables word du document
 
                Dim Tbl As Table
 
                Dim f As Field
 
                For Each Tbl In ActiveDocument.Tables
 
                        For Each f In ActiveDocument.Fields
 
                            'Nom du champs
 
                            Cells(1, f.Index).Value = .ActiveDocument.FormFields(f.Index).Name
 
                            'Valeur du champs si case à cocher
 
                                If f.Type = 71 Then
                                    Cells(2, f.Index).Value = .ActiveDocument.FormFields(f.Index).CheckBox.Value
 
                                Else 'autres champs
 
                                    Cells(2, f.Index).Value = f.Result.Text
                                End If
 
                        Next f
 
                Next Tbl
 
                'Ferme le document Word
 
                .Quit False
 
            End With
 
            'Destruction de l'objet word
 
            Set Wd = Nothing
 
        End If
 
    End If
 
End Sub

Essaies ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub ImportWord()
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdTbl As Word.Table
Dim wdFichier As String
Dim Sh As Worksheet
Dim NewLig As Long
 
Application.ScreenUpdating = False
wdFichier = "C:\Users\user\Desktop\Mondocument.docx"
Set Sh = ThisWorkbook.Sheets("Feuil3")
NewLig = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row + 2
With wdApp
   .Visible = False
   Set wdDoc = .Documents.Open(wdFichier)
   With wdDoc
      .Protect Type:=wdNoProtection
      For Each wdTbl In .Tables
         wdTbl.Range.Copy
         Sh.Range("A" & NewLig).Select
         Sh.PasteSpecial Format:="Texte"
         NewLig = NewLig + wdTbl.Rows.Count + 2
      Next wdTbl
      .Close
   End With
   .Quit False
   Set wdDoc = Nothing
End With
Set wdApp = Nothing
Set Sh = Nothing
End Sub

14/02/2011, 09h29
Vitalic

Tout d'abord merci beaucoup pour ta réponse.

J'ai testé ton code, malheureusement j'obtiens une erreur de compilation du type :

Citation:

La méthode Select de la classe Range a échoué
14/02/2011, 10h44
mercatog

Bonjour
Sur quelle ligne tu as l'erreur? as-tu exécuté le code pas à pas?
14/02/2011, 10h53
Vitalic

Bonjour,

J'aurai du préciser la ligne avant, désolé... pas très malin.
Donc, l'erreur se trouve sur cette ligne "Set wdDoc = .Documents.Open(wdFichier)"
J'ai fait un débogage pas à pas détaillé.

Encore merci :D
14/02/2011, 11h19
mercatog
As tu adapté le nom du chemin word à lire et le nom de la feuille Excel ici?
Code:

1 2 wdFichier = "C:\Users\user\Desktop\Mondocument.docx" Set Sh = ThisWorkbook.Sheets("Feuil3")
14/02/2011, 11h29
Vitalic

C'est bon ça marche !

Vraiment un grand merci à toi !

Sans vouloir abuser de ta générosité, j'aurais deux autres autres petites questions en fait...

J'aimerais savoir s'il est possible de ne copier que les champs (liste déroulante et texte) qui ne sont pas vides, et sans copier les titres des tableaux en fait.

Et également de pouvoir importer "côte à côte" les fichiers suivants, à la base j'en aurai 70...

Encore merci

pas clair pour moi
sinon, pour copier cellule par cellule à l'exception de la première ligne des tableaux Word, essaies comme ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub ImportWord()
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdTbl As Word.Table
Dim wdCel As Word.Cell
Dim wdFichier As String
Dim Sh As Worksheet
Dim j As Integer
 
Application.ScreenUpdating = False
wdFichier = "C:\Documents and Settings\Administrateur\Bureau\Mondocument.doc"
Set Sh = ThisWorkbook.Sheets("Feuil3")
Sh.Activate
With wdApp
    .Visible = False
    Set wdDoc = .Documents.Open(wdFichier)
    With wdDoc
        .Protect Type:=wdNoProtection
        For Each wdTbl In .Tables
            For Each wdCel In wdTbl.Range.Cells
                If wdCel.RowIndex > 1 Then
                    wdCel.Range.Copy
                    Sh.Cells(wdCel.RowIndex - 1, wdCel.ColumnIndex + j).Select
                    Sh.PasteSpecial Format:="Texte"
                End If
            Next wdCel
            j = j + wdTbl.Columns.Count
        Next wdTbl
        .Close
    End With
    .Quit False
    Set wdDoc = Nothing
End With
Set wdApp = Nothing
Set Sh = Nothing
End Sub

J'essaie d'être plus clair, ce qui n'est pas évident étant donné que la mise en page du word est assez complexe et rigide... du coup j'essaie de la modifier pour que ce soit plus simple...

J'ai retouché le dernier code que tu m'as proposé de sorte que la mise en page de mes tableaux soit conservée, ça ne marche pas trop mal mais le copier-coller cellule par cellule n'a plus l'air de fonctionner comme il faut...

Serait-il possible de:
- Me montrer comme conserver le copier coller cellule par cellule en conservant la mise en page word, ce que je crois avoir réussi d'après mon dernier test sur le code ci-dessous :)
- Commencer le copier coller à partir d'une page précise du word (en l'occurence page 4 pour moi)
- Pouvoir réitérer ceci pour plusieurs documents word de ce type sur la même page excel et sans que les copier coller se chevauchent en fait...

J'ai conscience de demander une aide sur mesure sans savoir si ceci est vraiment possible...

Encore et encore merci

Code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 Sub ImportWord2() Dim wdApp As New Word.Application Dim wdDoc As Word.Document Dim wdTbl As Word.Table Dim wdCel As Word.Cell Dim wdFichier As String Dim Sh As Worksheet Dim i As Integer, j As Integer Dim Cible As Variant Application.ScreenUpdating = False wdFichier = "Mon document" Set Sh = ThisWorkbook.Sheets("Feuil1") Sh.Activate With wdApp .Visible = False Set wdDoc = .Documents.Open(wdFichier) With wdDoc .Protect Type:=wdNoProtection For Each wdTbl In .Tables For i = 1 To wdTbl.Rows.Count For j = 1 To wdTbl.Columns.Count Cible = wdTbl.Columns(j).Cells(i) Sheets(1).Cells(i, j) = _ Application.WorksheetFunction.Substitute(Cible, vbCr, vbLf) Sheets(1).Cells(i, j) = _ Left(Sheets(1).Cells(i, j), Len(Sheets(1).Cells(i, j)) - 1) Next j Next i Next wdTbl .Close End With .Quit False Set wdDoc = Nothing End With Set wdApp = Nothing Set Sh = Nothing End Sub

Essaies ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Sub ImportWord3()
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdTbl As Word.Table
Dim Sh As Worksheet
Dim i As Integer, j As Integer
Dim LastLig As Long
Dim wdFichier As String, Chemin As String, Cible As String
Dim c As Range
 
Application.ScreenUpdating = False
Set Sh = ThisWorkbook.Sheets("Feuil1")
With Sh
   .Activate
   Set c = .Cells.Find("*", searchdirection:=xlPrevious, searchorder:=xlByRows)
   If Not c Is Nothing Then
      LastLig = c.Row
      Set c = Nothing
   End If
End With
 
Chemin = "C:\Users\user\Desktop\"   'Chemin de tes fichiers Word
wdFichier = Dir(Chemin & "*.doc*")
With wdApp
   .Visible = False
   Do While wdFichier <> ""
      Set wdDoc = .Documents.Open(Chemin & wdFichier)
      With wdDoc
         .Protect Type:=wdNoProtection
         For Each wdTbl In .Tables
            If wdTbl.Range.Information(wdActiveEndPageNumber) >= 4 Then
               For i = 2 To wdTbl.Rows.Count
                  For j = 1 To wdTbl.Columns.Count
                     Cible = wdTbl.Columns(j).Cells(i).Range.Text
                     Cible = Replace(Cible, vbCr, vbLf)
                     Cible = Left(Cible, Len(Cible) - 1)
                     Sh.Cells(i + LastLig, j) = Cible
                  Next j
               Next i
               LastLig = LastLig + wdTbl.Rows.Count
            End If
         Next wdTbl
         .Close False
      End With
      Set wdDoc = Nothing
      wdFichier = Dir
   Loop
   .Quit
End With
Set wdApp = Nothing
Set Sh = Nothing
MsgBox "Opération terminée..."
End Sub

Je ne peux que te remercier une nouvelle fois, c'est parfait!

J'ai complété par un bouton de mise en page comme suit:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub CommandButton1_Click()
 
    Application.ScreenUpdating = False
    Dim wkSt As String
    Dim wkBk As Worksheet
    wkSt = ActiveSheet.Name
    For Each wkBk In ActiveWorkbook.Worksheets
        On Error Resume Next
        wkBk.Activate
        Cells.EntireColumn.AutoFit
        Cells.EntireRow.AutoFit
        Cells.HorizontalAlignment = True
        Cells.VerticalAlignment = True
    Next wkBk
    Sheets(wkSt).Select
    Application.ScreenUpdating = True
 
End Sub

Du coup tout est propre... c'est super :ccool:

Pour la mise en page de toutes les feuilles de ton classeur

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub CommandButton1_Click()
Dim Sh As Worksheet
 
Application.ScreenUpdating = False
For Each Sh In ThisWorkbook.Worksheets
   With Sh.UsedRange
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .EntireColumn.AutoFit
      .EntireRow.AutoFit
   End With
Next Sh
End Sub

15/02/2011, 17h01
Vitalic

OK la mise en forme de toutes les feuilles !
Et est-il possible en plus d'intégrer un retour chariot sur toutes les cellules ?
Ce serait plus lisible
Merci