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