Discussion :

[dansdu]

Bonjour,

J'ai besoin de créer une macro pour automatiser le remplacement d'un mot dans word par un autre.
Je suis novice en VBA mais j'ai réussi à récupérer mon tableau excel sous forme de matrice ce qui me permet de faire correspondre le mot à chercher avec le mot à remplacer.
Mais la fonction "replace" ne fonctionne pas. (ligne 32)

Pourriez-vous m'aider?
Merci par avance,

Voila le code :

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
Dim DonneRef As New Collection
 
    'Feuille source
    Dim Feuille_Source As Worksheet
    Set Feuille_Source = Worksheets("Données")
    Feuille_Source.Activate
 
    'première ligne à chercher
    Dim first_row As Integer
    first_row = 1
 
 
    Application.ScreenUpdating = False
    A = Range("A" & first_row, [A65536].End(xlUp)).Value
    On Error Resume Next
    ' Boucle pour récupérer la collection d'items uniques
    For j = 1 To UBound(A, 1)
        DonneRef.Add A(j, 1), CStr(A(j, 1))
    Next j
    ' Réactivation du gestionnaire d'erreurs
    On Error GoTo 0
    'Récuparation des données dans une matrice B
    Range("A1").CurrentRegion.Select
    With Selection.CurrentRegion
        Intersect(.Cells, .Offset(1)).Select
    End With
    B = Selection.Value
 
Set wordapp = CreateObject("word.Application")
    wordapp.Visible = True
 
For j = 1 To UBound(B, 1)
    wordapp.Documents.Open "C:\Test Macro\" & B(j, 1) & ".doc"
    wordapp.Documents(B(j, 1) & ".doc").Activate
    wordapp.Selection.WholeStory
    With wordapp.Selection.Find
        .ClearFormatting
        .IgnoreSpace = True
        .Text = B(j, 1) 'texte à trouver
        .Wrap = wdFindcontinue
        .Replacement.ClearFormatting
        .Replacement.Text = B(j, 2) 'texte à remplacer
    End With
wordapp.Selection.Find.Execute Replace:=wdReplaceAll
 
wordapp.ActiveDocument.SaveAs Filename:=B(j, 2)
wordapp.ActiveDocument.Close
 
Next j
 
word.Application.Quit
Set wrdapp = Nothing

[Invité]

Bonjour,

A quoi vous sert votre variable collection ?
Que remplacez-vous dans votre fichier Word, des données dans un tableau ?

[dansdu]

Bonjour,

A quoi vous sert votre variable collection ?
Que remplacez-vous dans votre fichier Word, des données dans un tableau ?

Bonjour,

Effectivement, la variable collection ne me sert à rien dans cette macro. Merci de me l'avoir signalé...
Je cherche à remplacer :

1. un mot dans un corps de texte.
2. un mot dans un en-tête de page

[Invité]

Pour l'entête de page, il vous faut sélectionner le range correspondant à la partie header de la ou de vos sections de votre document.
Si vous avez la possibilité de mettre un exemple de vos deux fichiers sans données confidentielles, je peux regarder. Le cas échéant, zipez vos fichiers avec une extension .zip.

[dansdu]

Bonsoir,

J'ai créé un jeu de données très basique.
Test Macro.zip

[Invité]

Dans un module standard du fichier Excel :

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
100
101
102
 
Sub CopierEtMettreAJourLesFichiersWord()
 
Dim Feuille_Source As Worksheet
Dim AireSource As Range
Dim J As Long, PremiereLigne As Long, DerniereLigne As Long
'Dim WordApp As Word.Application, WordDoc As Word.Document  ' En early binding, cocher la référence Microsoft Word
Dim WordApp As Object, WordDoc As Object  ' En late binding, sans cocher la référence.
Dim Repertoire As String, NomDoc As String
Dim HeureDebut, HeureFin, TempsTotal
 
    On Error GoTo Fin
 
    Application.ScreenUpdating = False
 
    HeureDebut = Timer
    Repertoire = ActiveWorkbook.Path & "\"     ' A adapter
    Set Feuille_Source = Worksheets("Données")
 
 
    With Feuille_Source
         PremiereLigne = 2
         DerniereLigne = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
         Set AireSource = .Range(.Cells(PremiereLigne, "A"), .Cells(DerniereLigne, "A"))
    End With
 
    Set WordApp = CreateObject("word.Application")
    With WordApp
 
         .Visible = True
 
         For J = 1 To AireSource.Count
             NomDoc = Repertoire & AireSource(J) & ".doc"  ' Extension à adapter éventuellement
             If ExistenceFichier(NomDoc) = True Then
 
                Set WordDoc = WordApp.Documents.Open(NomDoc)
                With WordDoc.Range
                     .MoveStart unit:=6 'wdStory
                     .Select
                End With
                RemplacementDansLeRange WordApp.Selection, AireSource(J).Value, AireSource(J).Offset(0, 1).Value
 
                WordDoc.Sections(1).Headers(1).Range.Select  ' Headers(1) : 1 à adapter selon le type d'entête.
                RemplacementDansLeRange WordApp.Selection, AireSource(J).Value, AireSource(J).Offset(0, 1).Value
 
                WordDoc.SaveAs Filename:=Repertoire & AireSource(J).Offset(0, 1).Value
                WordApp.ActiveDocument.Close
 
                Set WordDoc = Nothing
 
             End If
 
         Next J
 
   End With
 
   Application.ScreenUpdating = True
 
   HeureFin = Timer
   TempsTotal = HeureFin - HeureDebut
 
   MsgBox "Temps total du traitement : " & Round(TempsTotal, 0) & " seconde(s)", vbInformation, "Copie et mise à jour des fichiers Word"
 
   GoTo Fin
 
Fin:
 
   Application.ScreenUpdating = True
 
   WordApp.Quit
   Set WordApp = Nothing: Set WordDoc = Nothing
   Set Feuille_Source = Nothing
 
End Sub
 
 
Sub RemplacementDansLeRange(ByVal SelectionEnCours As Object, ByVal ValeurATrouver As String, ByVal ValeurDeRemplacement As String)
 
    With SelectionEnCours
         .Find.ClearFormatting
         .Find.Replacement.ClearFormatting
         With .Find
              .Text = ValeurATrouver
              .Replacement.Text = ValeurDeRemplacement
              .Forward = True
              .Wrap = 1 ' wdFindContinue
         End With
         .Find.Execute Replace:=2 'wdReplaceAll
    End With
 
End Sub
 
 
Function ExistenceFichier(ByVal NomDuFichier As String) As Boolean
 
Dim Fso As Object
 
        Set Fso = CreateObject("Scripting.FileSystemObject")
        ExistenceFichier = Fso.FileExists(NomDuFichier)
        Set Fso = Nothing
 
End Function

[dansdu]

Bonsoir,

Waouh, Nickell!! Merci Beaucoup!!!