Discussion :

[dvdhag123]

Bonjour,
Je vous expose mon problème : Je souhaite importer certaines données de tout mes fichier word d'un dossier vers un fichier excel, de façon automatique

formule pour aller chercher le dossier = OK
formule pour ouvrir chaque fichier = OK

sur Word j'ai référencé sous "Contrôle de contenu" les données souhaitées en leur donnant un titre (dans mon exemple 1..12)
Formule copier coller donnée Word vers excel = pas OK car fonctionne à certains endroit puis s'arrête (debugage aléatoire..)

Le problème interviens de façon aléatoire, parfois sur le 1er fichier 2ere donnée importé, parfois sur le 4ème 10ème donnée, parfois à 2ème 3ème donnée, parfois la 10eme, ...., mais après ça se stop debugage
"Erreur d'exécution '1004' : la méthode PasteSpecial de la classe range a échoué."

Macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Sub Import_Donnees_W()
 
    ' -- Déclaration des variables
    Dim wb As Workbook          'classeur Excel dans lequel on importe les données
    Dim ws As Worksheet         'onglet Excel dans lequel on importe les données
    Dim sChemin As String       'répertoire contenant les fichiers Word
    Dim sNomFichier As String   'nom du fichier Word
    Dim WApp As Object, WDoc As Object, WSel As Object
    Dim i As Integer
 
 
    ' -- Initialisation des variables
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)                       'on sauvegarde dans la 1re feuille
    sChemin = ChoisirRepertoire & "\"          'fonction pour choisir le répertoire contenant les fichier Word
    'sChemin = ThisWorkbook.Path & "\"           'si les fichiers Word se trouvent dans le même répertoire que le fichier Excel
    sNomFichier = Dir(sChemin & "*.doc*")       'pour ouvrir tous les fichiers .doc*. 1er fichier.
 
    Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
    WApp.Visible = True                        'ne pas afficher Word pendant l'exécution
    i = ws.Range("A" & Rows.Count).End(xlUp).Row + 1   '1re ligne où on va écrire les données dans le fichier Excel
 
    Application.ScreenUpdating = False
 
    ' -- Boucle sur les fichiers
    Do While Len(sNomFichier) > 0
 
        Set WDoc = WApp.Documents.Open(sChemin & sNomFichier, ReadOnly:=True)   'ouvre le document Word
        Application.StatusBar = "Écriture ligne " & i       'message dans Excel pour voir la progression
 
        ' Nom du fichier
         ws.Cells(i, 1) = sNomFichier
 
 
                '1
        WDoc.SelectContentControlsByTitle("1").Item(1).Range.Copy  'Colonne2
        ws.Select
       ws.Cells(i, 3).PasteSpecial (xlPasteValues)
                '2
        WDoc.SelectContentControlsByTitle("2").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 3).PasteSpecial (xlPasteValues) 'Colonne3
                '3
        WDoc.SelectContentControlsByTitle("3").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 4).PasteSpecial (xlPasteValues) 'Colonne4
                '4
        WDoc.SelectContentControlsByTitle("4").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 5).PasteSpecial (xlPasteValues) 'Colonne5
                '5
        WDoc.SelectContentControlsByTitle("5").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 6).PasteSpecial (xlPasteValues) 'Colonne6
                '6
        WDoc.SelectContentControlsByTitle("6").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 7).PasteSpecial (xlPasteValues) 'Colonne7
                '7
        WDoc.SelectContentControlsByTitle("7").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 8).PasteSpecial (xlPasteValues) 'Colonne8
                '8
        WDoc.SelectContentControlsByTitle("8").Item(1).Range.Copy
                ws.Select
        ws.Cells(i, 9).PasteSpecial (xlPasteValues) 'Colonne9
                '9
         WDoc.SelectContentControlsByTitle("9").Item(1).Range.Copy
                 ws.Select
        ws.Cells(i, 10).PasteSpecial (xlPasteValues) 'Colonne10
                '10
        WDoc.SelectContentControlsByTitle("10").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 11).PasteSpecial (xlPasteValues) 'Colonne11
                '11
        WDoc.SelectContentControlsByTitle("11").Item(1).Range.Copy
                ws.Select
       ws.Cells(i, 12).PasteSpecial (xlPasteValues) 'Colonne12
                '12
        WDoc.SelectContentControlsByTitle("12").Item(1).Range.Copy
                ws.Select
        ws.Cells(i, 13).PasteSpecial (xlPasteValues) 'Colonne13
 
 
 
 
        i = i + 1                       'prochaine ligne
        WDoc.Close False                'fermer le document Word sans enregistrer
        sNomFichier = Dir               'prochain document
    Loop
 
SortieNormale:
    Application.ScreenUpdating = True
    WApp.Quit                           'Fermer l'instance de Word
    Application.StatusBar = False       'Remise à zéro de la barre d'état
 
End Sub

Fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
Function ChoisirRepertoire() As String
' -- Fonction permettant de choisir un répertoire
    Dim oRepertoire As Object
    ChoisirRepertoire = ""
    Set oRepertoire = CreateObject("Shell.Application").BrowseForFolder(0, "Choisir un répertoire", 0)
    If (Not oRepertoire Is Nothing) Then ChoisirRepertoire = oRepertoire.Items.Item.Path
    Set oRepertoire = Nothing
End Function

Merci pour votre aide car ça fait 3 semaines que je bloque complet

[Invité]

Bonjour,

Il vous faut regarder le type de vos ContentControls avant d'injecter. Que donne le résultat de ce code dans la fenêtre d'exécution sur votre document Word ? Il y a peut-être des valeurs non identifiées avec le Select Case.

On est sur Word...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Explicit
 
Public MatriceControles() As Variant
Public IndexMatrice As Integer
 
Sub TestListerLesContentControls()
 
    ListerLesContentControls ActiveDocument
    LireLaMatriceControles
 
End Sub
 
Sub ListerLesContentControls(ByVal WordDoc As Document)
 
Dim I As Integer
 
    IndexMatrice = 0
 
    With WordDoc
         For I = 1 To .ContentControls.Count
             With .ContentControls(I)
                  'Debug.Print "Titre : " & .Title & ", type : " & .Type & ", contenu : " & .Range.Text
                  ReDim Preserve MatriceControles(2, IndexMatrice)
                  MatriceControles(0, IndexMatrice) = .Title
                  MatriceControles(1, IndexMatrice) = .Type
                  Select Case .Type
                         Case 8
                              MatriceControles(2, IndexMatrice) = .Checked
                         Case Else
                              MatriceControles(2, IndexMatrice) = .Range.Text
 
                  End Select
                  IndexMatrice = IndexMatrice + 1
            End With
        Next I
   End With
 
End Sub
 
 
Sub LireLaMatriceControles()
 
    For IndexMatrice = LBound(MatriceControles, 2) To UBound(MatriceControles, 2)
        Debug.Print "Titre : " & MatriceControles(0, IndexMatrice) & ", type : " & MatriceControles(1, IndexMatrice) & ", contenu : " & MatriceControles(2, IndexMatrice)
    Next IndexMatrice
 
End Sub

[dvdhag123]

Bonjour,
Tout d'abord merci pour votre réponse rapide et merci pour cette macro !

Dans mon exemple le résultat est :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Titre : 1, type : 0, contenu : 1
Titre : 2, type : 0, contenu : 2
Titre : 3, type : 0, contenu : 3
Titre : 4, type : 0, contenu : 4
Titre : 5, type : 0, contenu : 5
Titre : 6, type : 0, contenu : 6
Titre : 7, type : 0, contenu : 7
Titre : 8, type : 0, contenu : 8
Titre : 9, type : 0, contenu : 9
10
Titre : 10, type : 0, contenu : 10
Titre : 11, type : 0, contenu : 11
Titre : 12, type : 0, contenu : 12

Mais dans mon fichier source j'ai :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Titre : NOM, type : 1, contenu : EDOUARD
Titre : PRENOM, type : 0, contenu : MANUEL
Titre : C, type : 3, contenu : FA
Titre : G, type : 3, contenu : BA
Titre : B, type : 3, contenu : F
Titre : VILLE, type : 0, contenu : ORLEAN
Titre : SEXE, type : 3, contenu : H
Titre : AGE, type : 0, contenu : 34
Titre : STAGIAIRE : 8, contenu : Vrai
Titre : INFO, type : 0, contenu : ECOLE
Titre : HORS ENTREPRISE : 8, contenu : Faux
Titre : INFO, type : 0, contenu :

[Invité]

A priori ce sont vos types 8 (booléens) qui foirent. La valeur à récupérer est checked. Il vaudrait mieux tester la valeur et assigner le résultat Vrai ou faux plutôt que de faire une copie.
Essayez déjà cette correction pour voir.

[dvdhag123]

J'ai du mal à concevoir la vérification

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 If WDoc.SelectContentControlsByTitle("STAGIAIRE") = True Then
            WDoc.SelectContentControlsByTitle("STAGIAIRE").Item(1).Range.Copy
            ws.Select
            ws.Cells(i, 12).PasteSpecial (xlPasteValues)
 End If

Après plusieurs essai je ne trouve pas la méthode

[Invité]

La matrice vous tend les bras, vous avez tout dedans.

Sinon, récupérez vos valeurs avec cette fonction :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Function ValeurContentControls(ByVal WordDoc As Document, ByVal TitreControle As String) As Variant
 
Dim I As Integer
 
    With WordDoc
         For I = 1 To .ContentControls.Count
             With .ContentControls(I)
                  If .Title = TitreControle Then
                     Select Case .Type
                            Case 8
                                 ValeurContentControls = .Checked
                            Case Else
                                 ValeurContentControls = .Range.Text
                      End Select
                      Exit Function
                  End If
            End With
        Next I
   End With
 
End Function

Et testez la avec :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
Sub TestValeur()
 
    Debug.Print ValeurContentControls(Wdoc, "NOM")
    Debug.Print ValeurContentControls(Wdoc, "STAGIAIRE ")
 
End Sub

[dvdhag123]

Désolé mais je suis totalement perdu, depuis ce matin j'essaie ....

[Invité]

Votre fichier Word comporte des homonymies dans les ContentControls. Testez le code contenu avec uniquement les fichiers joints. Il vous faut travailler avec un tableau structuré comme dans le fichier joint.

[dvdhag123]

Votre fichier Word comporte des homonymies dans les ContentControls. Testez le code contenu avec uniquement les fichiers joints. Il vous faut travailler avec un tableau structuré comme dans le fichier joint.

Vous êtes un génie, Je vais analyser tout le déroulement du code car j'ai du mal avec les contentcontrols

[Invité]

Si vos documents Word sont déjà existants, vous aurez le problème de leur mise à jour compte tenu de l'homonymie des noms dans vos contrôles.

Bon courage.

[Invité]

Pour info, j'ai mis votre exemple sur mon blog : Contentcontrols-transfert-donnees-dexcel-vers-word-word-vers-excel

L'exemple contient également le cas inverse, un tableau structuré génère les fichiers Word et met à jour les ContentControls.

[dvdhag123]

Merci, blog super intéressant !

J'invite tout le monde à y jeter un œil.