Exporter tableau word vers excel

Version imprimable

2 pièce(s) jointe(s)

Bonjour,
J'utilise VBA depuis peu. Je dois compiler plusieurs fichiers Word qui contiennent un tableau, dans un même fichier excel. Après quelques recherches, j'ai trouvé une programmation qui semble bien marcher pour toutes les cellules qui contiennent des contrôles de formulaire (merci à son auteur). Cependant, dans le tableau word, il y a des cellules qui ne contiennent que du texte et n'apparaissent pas dans mon fichier excel. J'ai fais plusieurs essais mais sans succès. Comment faire pour exporter le contenu de toutes les cellules et ce, peu importe leur format?

Merci à l'avance

Voici le 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
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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
'The complete VBA code to transfer data from Word forms into Excel:
Sub getWordFormData()
' définir quelques variables
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim FmFld As Word.FormField
'Dim CCtl As Word.ContentControls
 
 
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
' i pour une procédure en loop
' donner le chemin d'accès du dossier ou ce trouve les documents word
myFolder = "D:\Route et PM en vigueur\Changement huile test"
Application.ScreenUpdating = False
 
'pour fermer la macro si le dossier est vide
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
'effacer les données de la feuille, pour éviter d'avoir des doublons
'ActiveSheet.Cells.Clear
'inscrire les cellules et textes que l'on veux pour titre de colonnes
 
Range("B1") = "No tâche"
Range("B1").Font.Bold = True
Range("C1") = "No équipement"
Range("C1").Font.Bold = True
Range("D1") = "No moteur"
Range("D1").Font.Bold = True
Range("E1") = "Titre"
Range("E1").Font.Bold = True
Range("F1") = "Emplacement"
Range("F1").Font.Bold = True
Range("G1") = "Secteur"
Range("G1").Font.Bold = True
Range("H1") = "fréquence"
Range("H1").Font.Bold = True
Range("I1") = "PM"
Range("I1").Font.Bold = True
Range("J1") = "Pd"
Range("J1").Font.Bold = True
Range("K1") = "MD"
Range("K1").Font.Bold = True
Range("L1") = "PCE"
Range("L1").Font.Bold = True
Range("M1") = "Route"
Range("M1").Font.Bold = True
Range("N1") = "Arret"
Range("N1").Font.Bold = True
Range("O1") = "Marche"
Range("O1").Font.Bold = True
Range("P1") = "Mecanique"
Range("P1").Font.Bold = True
Range("Q1") = "Menuisier"
Range("Q1").Font.Bold = True
Range("R1") = "Électro"
Range("R1").Font.Bold = True
Range("S1") = "Opérateur"
Range("S1").Font.Bold = True
Range("T1") = "Estimation"
Range("T1").Font.Bold = True
 
'ca demande de compter le nb de ligne et colonne et de changer de ligne une fois la dernière colonne rempli
i = myWkSht.Cells(myWkSht.Rows.Count, 2).End(xlUp).Row
'pour prendre tous les documents word dans le dossier
strFile = Dir(myFolder & "\*.doc", vbNormal)
 
'une loop pour avoir toutes les données de tous les fichiers
While strFile <> ""
i = i + 1
 
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
 
With myDoc
j = 4
'pour dire de prendre tous les controles dans le fichier ContentControls
For Each FmFld In .FormFields
'mets la valeur en colonne en débutant a celle spécifié par j= " " ici c'est 4 pour la 4eme colonne
j = j + 1
myWkSht.Cells(i, j) = FmFld.Result
Next
'pour que les colonnes s'ajuste au texte
myWkSht.Columns.AutoFit
End With
'pour fermer le fichier et sans faire de sauvegarde
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
'pour fermer l'application word et purger les mémoires (vider presse papier)
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True
End Sub

Citation:

Envoyé par BeletPic

Bonjour,

Les tableaux dans les documents ne sont pas identiques en nombre de lignes. Le code ci-dessous se base sur le .docx qui ne contient pas de ligne vide.
Ce code ne règle pas tout, notamment votre boucle For Each FmFld In .FormFields.

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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
 
Option Explicit
 
Public MatriceInfo() As Variant
 
Sub getWordFormData()
 
Dim WdApp As New Word.Application
Dim MyDoc As Word.Document
Dim FmFld As Word.FormField
 
Dim MyFolder As String, StrFile As String
Dim MyWkSht As Worksheet, I As Long, j As Long
Dim IndexMatrice  As Integer
Dim Titre As Variant
 
    WdApp.Visible = True
    MyFolder = "D:\Route et PM en vigueur\Changement huile test"
 
    Application.ScreenUpdating = False
 
    If MyFolder = "" Then Exit Sub
 
    Set MyWkSht = ActiveSheet
 
    With MyWkSht
         Titre = Array("No tâche", "No équipement", "No moteur", "Titre", "Emplacement", "Secteur", "fréquence", "PM", "Pd", "MD", "PCE", "Route", "Arret", "Marche", "Mecanique", "Menuisier", "Électro", "Opérateur", "Estimation")
         With .Range("B1:T1")
             .Value = Titre
             .Font.Bold = True
         End With
         I = 2
    End With
 
    StrFile = Dir(MyFolder & "\*.doc*", vbNormal)
    While StrFile <> ""
 
          I = I + 1
 
          Set MyDoc = WdApp.Documents.Open(Filename:=MyFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
 
          With MyDoc
 
             j = 4
 
             ChargementMatrice MyDoc
 
             For Each FmFld In .FormFields
                 'mets la valeur en colonne en débutant a celle spécifié par j= " " ici c'est 4 pour la 4eme colonne
                 j = j + 1
                 MyWkSht.Cells(I, j) = FmFld.Result
             Next
 
             For IndexMatrice = LBound(MatriceInfo) To UBound(MatriceInfo)
 
                 'Debug.Print IndexMatrice & " : " & MatriceInfo(IndexMatrice)
 
                 Select Case IndexMatrice
                            Case 0   ' Tâche
                                 MyWkSht.Cells(I, 2) = Trim(Split(MatriceInfo(IndexMatrice), "No. Tâche: ")(1))
                            Case 2   ' Titre
                                 MyWkSht.Cells(I, 5) = MatriceInfo(IndexMatrice)
                            Case 12  ' Estimation
                                 MyWkSht.Cells(I, 20) = Trim(Split(MatriceInfo(IndexMatrice), " Estimation (hom.- heures):")(1))
                            Case 14  ' Equipement
                                 MyWkSht.Cells(I, 3) = MatriceInfo(IndexMatrice)
                            Case 15 ' Moteur
                                 MyWkSht.Cells(I, 4) = Trim(Split(MatriceInfo(IndexMatrice), "No. Moteur*:")(1))
                   End Select
               Next IndexMatrice
 
                'pour que les colonnes s'ajuste au texte
                MyWkSht.Columns.AutoFit
                End With
                'pour fermer le fichier et sans faire de sauvegarde
                MyDoc.Close SaveChanges:=False
                StrFile = Dir()
     Wend
 
     'pour fermer l'application word et purger les mémoires (vider presse papier)
     WdApp.Quit
     Set MyDoc = Nothing: Set WdApp = Nothing: Set MyWkSht = Nothing
     Application.ScreenUpdating = True
 
     MsgBox "Fin de l'import !", vbInformation
 
End Sub
 
Sub ChargementMatrice(ByVal MyDoc2 As Word.Document)
 
Dim K As Integer
 
    Erase MatriceInfo
 
    With MyDoc2.Tables(1)
         ReDim MatriceInfo(.Range.Cells.Count - 1)
         For K = 1 To .Range.Cells.Count
             With .Range.Cells(K)
                  MatriceInfo(K - 1) = Mid(.Range.Text, 1, Len(.Range.Text) - 1)
             End With
         Next K
    End With
 
End Sub

03/06/2020, 21h34
BeletPic

Bonjour Eric,
La programmation me donne un erreur dans la section indexMatrix, à la ligne

Code:

MyWkSht.Cells(I, 2) = Trim(Split(MatriceInfo(IndexMatrice), "No. Tâche: ")(1))

J'avoue ne pas tout comprendre. Trim sert a enlever les espacements inutiles, split sert a séparer la chaîne de caractère. C'est bien ca?
Merci de votre aide.
04/06/2020, 03h12
Invité

Citation:

Envoyé par BeletPic

Il faut supprimer la ligne vide (la première ligne) dans votre tableau du document .doc.
En ce qui concerne cette formule, Split renvoie ici un tableau de deux cellules dont la première (0) serait vide. L'indice (1) indique qu'on prend la deuxième cellule. Trim purge les espaces encadrant la chaîne récupérée.

Votre soucis sera d'avoir des tableaux aux dimensions homogènes, il vous faudra peut-être différencier les cas entre les deux types de tableaux (entre les deux il y a 3 cellules d'écart).

Le zip contient les fichiers utilisés.
05/06/2020, 19h11
BeletPic
Bonjour Eric,
Merci beaucoup pour les explications. Ca clarifie le code.
Je comprends aussi que je vais avoir beaucoup de travail afin de trier les différents document word pour avoir des groupes avec des tableaux identiques.
Cependant, il reste un problème avec la ligne suivante.
Code:

1 2 Case 16 ' Moteur MyWkSht.Cells(I, 4) = Trim(Split(MatriceInfo(IndexMatrice), "No. Moteur*:")(1))
J'ai regrouper quelques fichiers avec des tableaux identiques. La programmation ce déroule au complet mais il n'y a aucun no moteur qui apparaît. En changeant le 1 pour 0 à la fin, le titre "No. Moteur" ainsi que le numéro lui-même apparaissent. Ce n'est pas un gros problème, je vais le corriger avec une formule excel.

Encore une fois, merci beaucoup pour votre aide. C'est très apprécié.

Citation:

Envoyé par BeletPic

Si le nombre de lignes des tableaux est de 5 ou de 6, il suffit de tester leur nombre à l'ouverture et décaler les cellules selon les cas :

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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
 
 
Public MatriceInfo() As Variant
 
Sub getWordFormData()
 
Dim WdApp As New Word.Application
Dim MyDoc As Word.Document
Dim FmFld As Word.FormField
 
Dim MyFolder As String, StrFile As String
Dim MyWkSht As Worksheet, I As Long, j As Long
Dim IndexMatrice  As Integer
Dim Titre As Variant
 
    WdApp.Visible = True
    myFolder = "D:\Route et PM en vigueur\Changement huile test"
 
 
    Application.ScreenUpdating = False
 
    If MyFolder = "" Then Exit Sub
 
    Set MyWkSht = ActiveSheet
 
    With MyWkSht
         Titre = Array("No tâche", "No équipement", "No moteur", "Titre", "Emplacement", "Secteur", "fréquence", "PM", "Pd", "MD", "PCE", "Route", "Arret", "Marche", "Mecanique", "Menuisier", "Électro", "Opérateur", "Estimation")
         With .Range("B1:T1")
             .Value = Titre
             .Font.Bold = True
         End With
         I = 2
    End With
 
    StrFile = Dir(MyFolder & "\*.doc*", vbNormal)
    While StrFile <> ""
 
          I = I + 1
 
          Set MyDoc = WdApp.Documents.Open(Filename:=MyFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
 
          With MyDoc
 
             MsgBox .Tables(1).Rows.Count
 
 
             j = 4
 
             ChargementMatrice MyDoc
 
             For Each FmFld In .FormFields
                 'mets la valeur en colonne en débutant a celle spécifié par j= " " ici c'est 4 pour la 4eme colonne
                 j = j + 1
                 MyWkSht.Cells(I, j) = FmFld.Result
             Next
 
             Select Case .Tables(1).Rows.Count
 
                    Case 5
                         For IndexMatrice = LBound(MatriceInfo) To UBound(MatriceInfo)
                              'Debug.Print IndexMatrice & " : " & MatriceInfo(IndexMatrice)
                              Select Case IndexMatrice
                                     Case 0   ' Tâche
                                          MyWkSht.Cells(I, 2) = Trim(Split(MatriceInfo(IndexMatrice), "No. Tâche: ")(1))
                                     Case 2   ' Titre
                                          MyWkSht.Cells(I, 5) = MatriceInfo(IndexMatrice)
                                     Case 12  ' Estimation
                                          MyWkSht.Cells(I, 20) = Trim(Split(MatriceInfo(IndexMatrice), " Estimation (hom.- heures):")(1))
                                     Case 14  ' Equipement
                                          MyWkSht.Cells(I, 3) = MatriceInfo(IndexMatrice)
                                     Case 15 ' Moteur
                                          MyWkSht.Cells(I, 4) = Trim(Split(MatriceInfo(IndexMatrice), "No. Moteur*:")(1))
                               End Select
                          Next IndexMatrice
 
                     Case 6
                          For IndexMatrice = LBound(MatriceInfo) To UBound(MatriceInfo)
                              'Debug.Print IndexMatrice & " : " & MatriceInfo(IndexMatrice)
                              Select Case IndexMatrice
                                     Case 0   ' Tâche
                                          MyWkSht.Cells(I, 5) = Trim(Split(MatriceInfo(IndexMatrice), "No. Tâche: ")(1))
                                     Case 2   ' Titre
                                          MyWkSht.Cells(I, 8) = MatriceInfo(IndexMatrice)
                                     Case 12  ' Estimation
                                          MyWkSht.Cells(I, 23) = Trim(Split(MatriceInfo(IndexMatrice), " Estimation (hom.- heures):")(1))
                                     Case 14  ' Equipement
                                          MyWkSht.Cells(I, 6) = MatriceInfo(IndexMatrice)
                                     Case 15 ' Moteur
                                          MyWkSht.Cells(I, 7) = Trim(Split(MatriceInfo(IndexMatrice), "No. Moteur*:")(1))
                               End Select
                           Next IndexMatrice
               End Select
 
                'pour que les colonnes s'ajuste au texte
                MyWkSht.Columns.AutoFit
                End With
                'pour fermer le fichier et sans faire de sauvegarde
                MyDoc.Close SaveChanges:=False
                StrFile = Dir()
     Wend
 
     'pour fermer l'application word et purger les mémoires (vider presse papier)
     WdApp.Quit
     Set MyDoc = Nothing: Set WdApp = Nothing: Set MyWkSht = Nothing
     Application.ScreenUpdating = True
 
     MsgBox "Fin de l'import !", vbInformation
 
End Sub