Discussion :

[TheJon]

Bonjour à tous,

Je cherche à écrire une macro qui me permettra de rechercher et remplacer plusieurs termes dans de nombreux fichiers (plusieurs centaines).

Voici ce que j'ai pour l'instant :

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
Sub rechercher_remplacer_batch()
    Dim Directory As String
    Dim FType As String
    Dim FName As String
    'mettre ici le chemin d'accès au dossier où se trouvent les fichiers
    Directory = "C:\fic"
    FType = "*.rtf"
 
 
    ChDir Directory
 
    FName = Dir(FType)
 
    Do While FName <> ""
 
        Documents.Open FileName:=FName
 
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
' copier autant de fois qu'il y a d'éléments à remplacer
            .Text = "(-:"
            .MatchCase = True
            .Replacement.Text = "{0>"
            .MatchWildcards = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
 
' copier autant de fois qu'il y a d'éléments à remplacer
        With Selection.Find
            .Text = ")="
            .MatchCase = True
            .Replacement.Text = "<}"
            .MatchWildcards = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
 
 
' copier autant de fois qu'il y a d'éléments à remplacer
        With Selection.Find
            .Text = "101"
            .MatchCase = True
            .Replacement.Text = "100"
            .MatchWildcards = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
 
 
' copier autant de fois qu'il y a d'éléments à remplacer
        With Selection.Find
            .Text = "%("
            .MatchCase = True
            .Replacement.Text = "{>"
            .MatchWildcards = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
 
 
' copier autant de fois qu'il y a d'éléments à remplacer
        With Selection.Find
            .Text = ":-)"
            .MatchCase = True
            .Replacement.Text = "<0}"
            .MatchWildcards = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
 
        ActiveDocument.Close wdSaveChanges
 
        FName = Dir
    Loop
 
End Sub

Parfois la macro fonctionne sur un ou deux fichiers, parfois elle ne se lance pas du tout. Lorsque j'ai un message d'erreur, VBA me signale qu'il ne trouve pas tel ou tel fichier, pas forcément le même à chaque fois. La macro fonctionne en général sur au moins un fichier avant de planter.

De toute évidence je loupe quelque chose, mais j'ai beau triturer ce bout de code, je tourne en rond !

Merci d'avance à ceux qui pourront m'aider !

[Heureux-oli]

Salut,

Une piste là : http://heureuxoli.developpez.com/off...-et-remplacer/

[clementmarcotte]

Bonjour,

Je n'ai pas des tonnes de fichiers RTF sous la main, pour tester, mais voici de quoi, pour éviter quelques répétitions de cette partie:

Code :

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

1
2
3
4
5
6
7
8
9
 
With Selection.Find
' copier autant de fois qu'il y a d'éléments à remplacer
      .Text = "(-:"
      .MatchCase = True
      .Replacement.Text = "{0>"
      .MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

J'ai mis les "mots avant" dans la colonne a d'une feuille Excel, et les "mots après" correspondants dans la colonne b. Je les récupères dans un dictionnaire et je boucle sur les dictionnaire. Attention, j'ai mis le nom du fichier Excel et le nom du dossier en dur dans le code. Tu vas devoir adapter. Et puis, n'oublie pas d'ajouter les références indiquées dans les commentaires du début.

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
Sub ChangerDesMotsAvecSourceDesMotsDansExcel()
'IMPORTANT.
'Ajouter la référence à Microsoft Scripting Runtime
'et la référence à ExcelXX Objects Library
'Sinon, cela va joyeusement planter
'Les mots à remplacer sont dans la "Feuil1" en colonne A
'Les nouveaux mots sont dans la "Feuil1" en colonne B
    Dim AppExcel As Excel.Application
    Dim Feuille As Excel.Worksheet
    Dim Classeur As Excel.Workbook
    Dim AvantAprès As Scripting.Dictionary
    Set AvantAprès = New Scripting.Dictionary
    Set AppExcel = New Excel.Application
    Set Classeur = AppExcel.Workbooks.Open("C:\Test\Substituts.xlsx")
    Set Feuille = Classeur.Sheets("Feuil1")
    Dim LeDernier As Integer
    LeDernier = Feuille.UsedRange.Rows.Count
    'Récupérer les couples de mots à changer et
    'leur remplaçants
    For i = 1 To LeDernier
        AvantAprès.Add Key:=Feuille.Cells(i, 1).Value, Item:=Feuille.Cells(i, 2).Value
    Next
    AppExcel.Quit
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    Dim repertoire As Scripting.Folder
    Dim lefichier As Scripting.File
    Dim lesfichiers As Scripting.Files
    Set repertoire = fso.GetFolder("C:\Test")
    Set lesfichiers = repertoire.Files
    Dim LesClefs
    Dim LesItems
    LesClefs = AvantAprès.Keys
    LesItems = AvantAprès.Items
    Dim cefichier As String
    For Each lefichier In lesfichiers
        If UCase(Right(lefichier.Name, 4)) = ".RTF" Then
            Documents.Open FileName:=lefichier.Path
            For i = 0 To AvantAprès.Count - 1
                LaClef = LesClefs(i)
                LItem = LesItems(i)
                Selection.Find.ClearFormatting
                Selection.Find.Replacement.ClearFormatting
                With Selection.Find
                    .Text = LaClef
                    .MatchCase = True
                    .Replacement.Text = LItem
                    .MatchWildcards = False
                End With
                Selection.Find.Execute Replace:=wdReplaceAll
 
            Next
            Documents(lefichier.Path).Save
            Documents(lefichier.Path).Close
         End If
    Next
End Sub