XL 2010 Rechercher remplacer une adresse dans tous les documents

[fb62840]

Bonjour à toutes et tous,

Aurriez-vous une solution me permettant depuis excel de faire ceci :
regarder dans tous les documents words présents dans un répertoire si une adresse est présente et, si c'est le cas, remplacer l'adresse par une nouvelle adresse et sauvegarder le document sous son nom actuel auquel on ajoute Modif_date_du_jour ?

Merci beaucoup

 

[job75]

Bonjour fb62840,

Téléchargez les fichiers joints dans le même dossier (le bureau) et exécutez la macro :

Sub Remplacer()
Dim cherche$, remplace$, chemin$, Wapp As Object, doc$, Wd As Object, i
cherche = [D4] 'à adapter
remplace = [D6] 'à adapter
If cherche = "" Or remplace = "" Then Exit Sub
chemin = ThisWorkbook.Path & "\"
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
doc = Dir(chemin & "*.docx") '1er document Word du dossier
While doc <> ""
    Set Wd = Wapp.Documents.Open(chemin & doc)
    Wapp.Selection.WholeStory
    With Wapp.Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = cherche
        .Replacement.Text = remplace
        .Execute Replace:=2 'wdReplaceAll
    End With
    If Not Wd.Saved Then Wd.SaveAs chemin & Left(doc, Len(doc) - 5) & "-Modification-" & Format(Date, "dd-mm-yyyy") & ".docx"
    Wd.Close 'ferme le document Word
    doc = Dir 'document suivant
Wend
Wapp.Quit 'ferme Word
End Sub

A+

 

[job75]

Bonjour fb62840, le forum,

Il y a un problème si un document Word du dossier est ouvert quand on lance la macro.

Utilisez donc ce fichier (2) et la macro qui ferme les documents ouverts :

Sub Remplacer()
Dim cherche$, remplace$, chemin$, Wapp As Object, doc$, Wd As Object, i
cherche = [D4] 'à adapter
remplace = [D6] 'à adapter
If cherche = "" Or remplace = "" Then Exit Sub
chemin = ThisWorkbook.Path & "\"
On Error Resume Next 'si Word n'est pas déjà ouvert
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
doc = Dir(chemin & "*.docx") '1er document Word du dossier
While doc <> ""
    Wapp.Documents(doc).Close False 'ferme le document s'il est ouvert
    Set Wd = Wapp.Documents.Open(chemin & doc)
    Wapp.Selection.WholeStory
    With Wapp.Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = cherche
        .Replacement.Text = remplace
        .Execute Replace:=2 'wdReplaceAll
    End With
    If Not Wd.Saved Then Wd.SaveAs chemin & Left(doc, Len(doc) - 5) & "-Modification-" & Format(Date, "dd-mm-yyyy") & ".docx"
    Wd.Close 'ferme le document Word
    doc = Dir 'document suivant
Wend
If Wapp.Documents.Count = 0 Then Wapp.Quit 'ferme Word si aucun document n'est ouvert
End Sub

Edit : ajouté à la fin If Wapp.Documents.Count = 0 Then devant Wapp.Quit.

A+