XL 2010 Rechercher remplacer une adresse dans tous les documents

fb62840

XLDnaute Impliqué
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

XLDnaute Barbatruc
Bonjour fb62840,

Téléchargez les fichiers joints dans le même dossier (le bureau) et exécutez la macro :
VB:
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+
 

Pièces jointes

  • Word remplacer(1).xlsm
    19.1 KB · Affichages: 5
  • Doc1.docx
    11.8 KB · Affichages: 4
  • Doc2.docx
    11.9 KB · Affichages: 3
  • Doc3.docx
    11.7 KB · Affichages: 3

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • Word remplacer(2).xlsm
    19.8 KB · Affichages: 4
Dernière édition:

Discussions similaires