[VBA Excel] Automatiser copier-coller

Version imprimable

Voir 40 message(s) de cette discussion en une page

16/07/2015, 11h21
SfJ5Rpw8

Bonjour,

MACID ? tu est vraiment sous Macintosh ?
16/07/2015, 12h23
Beldramma

Non... mais ce qui m'etait donné quand j'ai fait F1
Donc je dois mettre quoi à la place ?

Finalement j'ai trouvé, je l'ai remplacé par

Code:

sNomFichier = Dir(sChemin & (ws.Cells(i, 9).Value))

mais j'ai mis dans la cellule le nom complet
Or normalement, le nom n'est pas complet. Et si j'execute cette ligne en remettant ce qu'il y a dans la cellule normalement, le programme ne trouve pas le document.
Existe-t-il une manière pour dire à ma commande de chercher les documents qui contiennent les caractères de la cellule et non de dire à la commande que le nom du doc est ce qu'il y a dans la cellule ?

Aussi, il se peut que pour ce que contient la cellule, cela renvoie à plusieurs fichiers au lieu d'un. Ainsi j'aimerais que si le nombre de fichiers correspondants est supérieur à 1, on passe directement à la ligne suivante. Comment puis je le mettre dans mon programme ?

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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
'Option Explicit
 
' ----------------------------------------------------------------
' Extraction dedonnées à partir de fichier Word vers Excel
'-----------------------------------------------------------------
Public Enum colExcelConsigne
    statut = 2
    'debutNomWord = 9
    PremierdebutNomWord = 7
    SeconddebutNomWord = 8
    sConsignes = 18
    sCriticité = 17
End Enum
 
 
' pour utiliser ce programme il faut instrumenter la preference : Microsoft Word 9.0 Object library
 
Sub Importation_Donnees_Word()
 
    ' -- 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
    Dim i As Integer            'numéro de ligne dans le tableau excel
    Dim Lw As Integer           'numéro de ligne dans le tableau word
 
    Dim tabListeFile() As Variant
    Dim saut_de_ligne As Integer
    Dim numéro_caractere As Integer
 
    ' -- Initialisation des variables
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)                       'on sauvegarde dans la 1re feuille
    sChemin = "C:\"    'fonction pour choisir le répertoire contenant les fichier Word
 
 
 
 
 
 
 
    Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
    WApp.Visible = False                       'Indiquez False pour garder l'application masquée
 
 
    Application.ScreenUpdating = False
 
    sNomFichier = ""
    'STEP 1
    'On rempli un tableau qui comprend le path complet des fichiers de consigne
    'TODO mettre en place un filtre sur .doc/.docx
    sNomFichier = Dir(sChemin)
    While (sNomFichier <> "")
 
        'Debug.Print li & "-" & sNomFichier
        ReDim Preserve tabListeFile(li)
        tabListeFile(li) = sNomFichier
        li = li + 1
        sNomFichier = Dir()
    Wend
 
    lLigneDebutExcel = 3 '3
    lNbreFichierWord = 2116 '2116
 
   'STEP 2 on recherche le fichier à ouvrir
   '
   ' -- Boucle qui incrémente les lignes Excel
    For lLigneExcel = lLigneDebutExcel To lLigneDebutExcel + lNbreFichierWord '2119 Nombre total de ligne à remplir
        cpt = 0
        '-- Boucle qui incrémente le tableau tabListeFile
        For lLigneTableau = 0 To UBound(tabListeFile)
            'Check si la ligne Excel est à traiter
            'debutNomWord Différent de "" et statut=NEW
 
            sPremierePartieDebutNomWordFromExcel = UCase(ws.Cells(lLigneExcel, colExcelConsigne.PremierdebutNomWord).Value)
            sDeuxiemePartieDebutNomWordFromExcel = UCase(ws.Cells(lLigneExcel, colExcelConsigne.SeconddebutNomWord).Value)
            sNomCompletDuFichier = UCase(tabListeFile(lLigneTableau))
 
            'Debug.Print "sDebutNomWordFromExcel:" & "-" & lLigneExcel & "-" & sDebutNomWordFromExcel
            'Debug.Print "sNomCompletDuFichier:" & "-" & lLigneTableau & "-" & sNomCompletDuFichier
 
 
             If (Trim(sPremierePartieDebutNomWordFromExcel) <> "") And (Trim(sDeuxiemePartieDebutNomWordFromExcel) <> "") And (UCase(ws.Cells(lLigneExcel, colExcelConsigne.statut).Value) = "NEW") Then
 
 
                If InStr(sNomCompletDuFichier, sPremierePartieDebutNomWordFromExcel) <> 0 And InStr(sNomCompletDuFichier, sDeuxiemePartieDebutNomWordFromExcel) <> 0 Then
 
                'If (sDebutNomWordFromExcel = UCase("pemo_aoly2019_stopusreom")) Then
                '   Debug.Print "-------------------------pemo_aoly2019_stopusreom-----------------------------------------------------"
                'End If
 
 
                    cpt = cpt + 1
 
                    'STEP 3 on récupére les infos du fichier word pour les coller dans le fichier Excel
                    Debug.Print "------------------------------------------------------------------------------"
                    Debug.Print "sNomCompletDuFichier:" & "-" & lLigneTableau & "-" & sNomCompletDuFichier
                    Debug.Print "------------------------------------------------------------------------------"
                    '
                    sPathCompletWord = sChemin & sNomCompletDuFichier
                    Set WDoc = WApp.Documents.Open(sPathCompletWord)    'ouvre le document Word
 
 
                     For i = 1 To WDoc.Tables(1).Rows.Count
 
                            sInfo = WDoc.Tables(1).Rows(i).Cells(1) 'On attribue à sInfo le contenu de la cellule 1 à la ligne i
 
 
                            If InStr(1, sInfo, "Instructions") <> 0 Or InStr(1, sInfo, "Consignes") <> 0 Then  'Si on trouve le mot "Consignes" à la ligne i alors
 
                               If InStr(1, LCase(sInfo), "critique") <> 0 Or InStr(1, LCase(sInfo), "critical") <> 0 Or InStr(1, LCase(sInfo), "crititique") <> 0 Then     'Si on trouve le mot critique à la ligne i alors
 
                            saut_de_ligne = InStr(1, sInfo, Chr(13)) 'On cherche le numéro du premier retour chariot
                            nombre_caractere = saut_de_ligne - 1
 
                            Criticité = Left(sInfo, nombre_caractere) 'On copie tout ce qu'il y a avant le retour chariot dans la variable Criticité
 
                            ws.Cells(lLigneExcel, sCriticité) = Criticité 'on colle son contenu dans la ligne excel correpondante dans la colonne Criticité
 
                            Debut_Description = saut_de_ligne + 1
                            sDescription = Mid(sInfo, Debut_Description)
                            ws.Cells(lLigneExcel, sConsignes) = sDescription ' on colle la valeur dana la cellule
                            Else
                            ws.Cells(lLigneExcel, sCriticité) = "Absent"
                            sDescription = Mid(sInfo, 11)
                            ws.Cells(lLigneExcel, sConsignes) = sDescription 'colle la valeur dana la cellule
                                End If
 
 
 
 
 
 
 
 
 
                             End If
 
 
 
 
 
 
 
                    Next i
                'WDoc.Bookmarks
 
 
 
                   WDoc.Close    'fermeture document Word
 
 
 
                End If
 
 
            End If
 
 
 
        Next
        'If (cpt > 1) Then
        '    Debug.Print sMyFile & ":" & cpt
        'End If
 
 
 
 
    Next
 
    WApp.Quit    'fermeture session Word
 
 
End Sub

J'ai pas mal avancé de mon côté voila mon code.

Il me reste une dernière partie que j'aimerais faire, en effet mon programme cherche dans les fichiers word des tableaux mais ces fichiers sont vieux et dans mon entreprise, ils sont en train de passer ces fichiers .doc en .docx.

Dans ces fichiers ils ont remplacé le tableau par des signets. Ce que j'aimerais faire maintenant serait une boucle for qui parcourerait tous les signets de ce fichier word et chercherai dedans les mots clé "Consignes" ou "Instructions.

J'avais commencé 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
For j = 1 To WordDoc.Bookmarks(numero_signet) 'on parcoure tous les signets du fichiers word ouvert
 
        numero = signet + 1
         WordDoc.Bookmarks(numero_signet).Range.Text = Cells(i, 1) 'On attribue le contenu du signet à une variable sInfo
 
    If InStr(1, sInfo, "Instructions") <> 0 Or InStr(1, sInfo, "Consignes") <> 0 Then  'Si on trouve le mot "Consignes" dans la variable alors
 
                               If InStr(1, LCase(sInfo), "critique") <> 0 Or InStr(1, LCase(sInfo), "critical") <> 0 Or InStr(1, LCase(sInfo), "crititique") <> 0 Then     'Si on trouve le mot critique dans la variable alors
 
                            saut_de_ligne = InStr(1, sInfo, Chr(13)) 'On cherche le numéro du premier retour chariot
                            nombre_caractere = saut_de_ligne - 1
 
                            Criticité = Left(sInfo, nombre_caractere) 'On copie tout ce qu'il y a avant le retour chariot dans la variable Criticité
 
                            ws.Cells(lLigneExcel, sCriticité) = Criticité 'on colle son contenu dans la ligne excel correpondante dans la colonne Criticité
 
                            Debut_Description = saut_de_ligne + 1
                            sDescription = Mid(sInfo, Debut_Description)
                            ws.Cells(lLigneExcel, sConsignes) = sDescription ' on colle la valeur dana la cellule
                            Else
                            ws.Cells(lLigneExcel, sCriticité) = "Absent"
                            sDescription = Mid(sInfo, 11)
                            ws.Cells(lLigneExcel, sConsignes) = sDescription 'colle la valeur dana la cellule
                                End If
         Next j

Mais je ne pense pas que ce programme marche.

Merci de votre aide...

23/07/2015, 11h53
joe.levrai

Bonjour,

1) que représente ta variable "numero" en ligne 3
2) que représente ta variable "signet" en ligne 3
==> t'as une variable "numero_signet" mais pas les deux dont je viens de parler
3) à quoi sert cet incrément effectué en ligne 3
4) ta boucle For/Next en ligne 1 a été modifiée pour utiliser la variable j ... or tu as encore des références à l'ancienne variable i en ligne 4

Voilà, regarde ces diverses problématiques pour commencer

Voila mon code peaufiné:

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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
'Option Explicit
 
' ----------------------------------------------------------------
' Extraction dedonnées à partir de fichier Word vers Excel
'-----------------------------------------------------------------
Public Enum colExcelConsigne
    statut = 2 'colonne du même nom
    PremierdebutNomWord = 7 'colonne G
    SeconddebutNomWord = 8 'colonne H
    ColonneNomComplet = 9 'colonne I
    sCriticité = 17 'Colonne Q
    sConsignes = 18 'Colonne R
 
End Enum
 
 
' pour utiliser ce programme il faut instrumenter la preference : Microsoft Word 9.0 Object library
 
Sub Importation_Donnees_Word()
 
    ' -- 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          'Fenêtre word
    Dim WDoc As Object
    Dim i As Integer            'numéro de ligne dans le tableau word
 
 
    Dim tabListeFile() As Variant        'tableau virtuel créé à partir du répertoire sChemin
    Dim saut_de_ligne As Integer          'numéro du premier retour chariot
    Dim li As Integer                    'compteur
    Dim lLigneDebutExcel As Integer      'ligne Excel de départ
    Dim lNbreFichierWord As Integer       'Variable additionné à lLigneDebutExcel pour donner lLigneExcel
    Dim lLigneExcel As Integer           'Numéro de ligne Excel
    Dim cpt As Integer                   'compteur
    Dim lLigneTableau                              'numéro de ligne dans le tableau virtuel tabListeFile()
    Dim sPremierePartieDebutNomWordFromExcel As Variant 'texte dans la colonne G à la ligne lLigneExcel
    Dim sDeuxiemePartieDebutNomWordFromExcel As Variant 'texte dans la colonne H à la ligne lLigneExcel
    Dim sNomCompletDuFichier As Variant            'Comme son nom l'indique
    Dim sPathCompletWord As Variant                'Chemin et nom complet du fichier
    Dim sInfo As Variant                           'Contient les infos du tableau word à la ligne i
    Dim nombre_caractere As Integer                'nombre de caractères à copier à partir de la gauche dans le fichier word à la ligne i
    Dim Criticité As Variant                       'Texte qu'on colle à la ligne lLigneExcel dans la colonne Criticité
    Dim Debut_Description As Integer               'numéro de caractère à partir duquel on copie le texte dans le fichier word à la ligne i
    Dim sDescription As Variant                    'Texte qu'on colle à la ligne lLigneExcel dans la colonne Consignes
 
    ' -- Initialisation des variables
    Set wb = ThisWorkbook                       'on sauvegarde dans la page excel ouverte
    Set ws = wb.Sheets(1)                       'on sauvegarde dans le premier onglet
    sChemin = "J:\200 - Applications_ISY\20.33 - Advantage\Antoine\NSM - Monaco\Monaco\"    'fonction pour choisir le répertoire contenant les fichier Word
 
 
    Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
    WApp.Visible = True                       'Indiquez False pour garder l'application masquée
 
 
    Application.ScreenUpdating = False
 
    sNomFichier = ""
    'STEP 1
    'On rempli un tableau qui comprend le path complet des fichiers de consigne
    'TODO mettre en place un filtre sur .doc/.docx
    sNomFichier = Dir(sChemin)
    While (sNomFichier <> "")
 
        'Debug.Print li & "-" & sNomFichier
        ReDim Preserve tabListeFile(li)
        tabListeFile(li) = sNomFichier
        li = li + 1
        sNomFichier = Dir()
    Wend
 
    lLigneDebutExcel = 3 '3
    lNbreFichierWord = 2116 '2116
 
   'STEP 2 on recherche le fichier à ouvrir
   '
   ' -- Boucle qui incrémente les lignes Excel
    For lLigneExcel = lLigneDebutExcel To lLigneDebutExcel + lNbreFichierWord '2119 Nombre total de ligne à remplir
        cpt = 0
 
        For lLigneTableau = 0 To UBound(tabListeFile)
 
            sPremierePartieDebutNomWordFromExcel = UCase(ws.Cells(lLigneExcel, colExcelConsigne.PremierdebutNomWord).Value)
            sDeuxiemePartieDebutNomWordFromExcel = UCase(ws.Cells(lLigneExcel, colExcelConsigne.SeconddebutNomWord).Value)
            sNomCompletDuFichier = UCase(tabListeFile(lLigneTableau))
 
 
 
            If (Trim(sPremierePartieDebutNomWordFromExcel) <> "") And (Trim(sDeuxiemePartieDebutNomWordFromExcel) <> "") And (UCase(ws.Cells(lLigneExcel, colExcelConsigne.statut).Value) = "NEW") Then
                 If InStr(sNomCompletDuFichier, sPremierePartieDebutNomWordFromExcel) <> 0 And InStr(sNomCompletDuFichier, sDeuxiemePartieDebutNomWordFromExcel) <> 0 Then
                    cpt = cpt + 1
 
                End If
            End If
        Next
 
 
        If (cpt = 1) Then
        '-- Boucle qui incrémente le tableau tabListeFile
        For lLigneTableau = 0 To UBound(tabListeFile)
        cpt = 0
            'Check si la ligne Excel est à traiter
            'debutNomWord Différent de "" et statut=NEW
 
            sPremierePartieDebutNomWordFromExcel = UCase(ws.Cells(lLigneExcel, colExcelConsigne.PremierdebutNomWord).Value)
            sDeuxiemePartieDebutNomWordFromExcel = UCase(ws.Cells(lLigneExcel, colExcelConsigne.SeconddebutNomWord).Value)
            sNomCompletDuFichier = UCase(tabListeFile(lLigneTableau))
 
            'Debug.Print "sDebutNomWordFromExcel:" & "-" & lLigneExcel & "-" & sDebutNomWordFromExcel
            'Debug.Print "sNomCompletDuFichier:" & "-" & lLigneTableau & "-" & sNomCompletDuFichier
 
 
             If (Trim(sPremierePartieDebutNomWordFromExcel) <> "") And (Trim(sDeuxiemePartieDebutNomWordFromExcel) <> "") And (UCase(ws.Cells(lLigneExcel, colExcelConsigne.statut).Value) = "NEW") Then
 
 
                If InStr(sNomCompletDuFichier, sPremierePartieDebutNomWordFromExcel) <> 0 And InStr(sNomCompletDuFichier, sDeuxiemePartieDebutNomWordFromExcel) <> 0 Then
 
                'If (sDebutNomWordFromExcel = UCase("pemo_aoly2019_stopusreom")) Then
                '   Debug.Print "-------------------------pemo_aoly2019_stopusreom-----------------------------------------------------"
                'End If
 
 
                    cpt = cpt + 1
 
                    'STEP 3 on récupére les infos du fichier word pour les coller dans le fichier Excel
                    Debug.Print "------------------------------------------------------------------------------"
                    Debug.Print "sNomCompletDuFichier:" & "-" & lLigneTableau & "-" & sNomCompletDuFichier
                    Debug.Print "------------------------------------------------------------------------------"
                    '
                    sPathCompletWord = sChemin & sNomCompletDuFichier
                    ws.Cells(lLigneExcel, ColonneNomComplet) = sNomCompletDuFichier
                    Set WDoc = WApp.Documents.Open(sPathCompletWord, ReadOnly = False)  'ouvre le document Word
 
 
                     For i = 1 To WDoc.Tables(1).Rows.Count
                       For j = 1 To WDoc.Tables(1).Columns.Count
                                'sInfo = WDoc.Tables(1).Columns(j).Cells(i)
 
                                On Error Resume Next
                                sInfo = WDoc.Tables(1).Cell(i, j).Range
                                If Err.Number <> 0 Then
                                    Exit For
                                    Err.Clear
                                End If
                            'sInfo = WDoc.Tables(1).Rows(i).Cells(1) 'On attribue à sInfo le contenu de la cellule 1 à la ligne i
 
 
                            If InStr(1, sInfo, "Instructions") <> 0 Or InStr(1, sInfo, "Consignes") <> 0 Or InStr(1, sInfo, "Consigne") <> 0 Or InStr(1, sInfo, "Consigns") <> 0 Or InStr(1, LCase(sInfo), "critique") <> 0 Then  'Si on trouve le mot "Consignes" à la ligne i alors
 
                               If InStr(1, LCase(sInfo), "critique") <> 0 Or InStr(1, LCase(sInfo), "critical") <> 0 Or InStr(1, LCase(sInfo), "crititique") <> 0 Or InStr(1, LCase(sInfo), "bloquant") <> 0 Then     'Si on trouve le mot critique à la ligne i alors
 
                            saut_de_ligne = InStr(1, sInfo, Chr(13)) 'On cherche le numéro du premier retour chariot
                            nombre_caractere = saut_de_ligne - 1
 
                            Criticité = Left(sInfo, nombre_caractere) 'On copie tout ce qu'il y a avant le retour chariot dans la variable Criticité
 
                            ws.Cells(lLigneExcel, sCriticité) = Criticité 'on colle son contenu dans la ligne excel correpondante dans la colonne Criticité
 
                            Debut_Description = saut_de_ligne + 1
                            sDescription = Mid(sInfo, Debut_Description)
                            ws.Cells(lLigneExcel, sConsignes) = sDescription ' on colle la valeur dana la cellule Consignes
 
                            Else
                            ws.Cells(lLigneExcel, sCriticité) = "Absent"
                            sDescription = Mid(sInfo, 11)
                            ws.Cells(lLigneExcel, sConsignes) = sDescription 'colle la valeur dana la cellule Consignes
 
                                End If
 
 
 
 
 
 
 
 
 
                             End If
 
 
 
 
 
 
 
                    Next j
 
 
                   Next i
 
                   WDoc.Close    'fermeture document Word
 
 
 
                End If
 
 
            End If
 
 
 
        Next
 
       End If
 
        If (cpt > 1) Then
        Debug.Print sPathCompletWord & ":" & cpt
       ws.Cells(lLigneExcel, ColonneNomComplet) = "Plusieurs fichiers correpondants"
    End If
 
 
 
    Next
 
    WApp.Quit    'fermeture session Word
 
 
End Sub

Alors ta question 1 et 2, je voulais mettre numero_signet aux deux.
Pour la question 3, Cela devait servir pour parcourir tous les signets.
Merci pour 4eme remarque je n'avais pas vu :)

24/07/2015, 15h44
joe.levrai

Ces petits ajustements fait, tu ne nous dis pas s'il reste des anomalies ou des problématiques dans ton code

Voir 40 message(s) de cette discussion en une page