Option Explicit Private oDocListe As Document Private oDocTravail As Document
Sub xxxx() Dim oRange As Range Dim oWord As Range Set oDocListe = Documents.Open("C:\Temp\Liste mots formatés.docx", ReadOnly:=True) Set oDocTravail = Documents.Open("C:\Temp\Test format.docx") ' Parcoure notre liste de mots formatés Set oRange = oDocListe.Range(Start:=0, End:=oDocListe.Characters.Count) For Each oWord In oRange.Words If (oWord.Text <> vbCr) And _ (oWord.Text <> vbNullString) Then Call ChercheEtFormate(oWord) End If Next oWord oDocListe.Close SaveChanges:=False oDocTravail.Close ' oDocTravail.Close SaveChanges:=True Debug.Print "Terminé" End Sub '------------------------------------------------- Sub ChercheEtFormate(ByVal TheMot As Range) Dim oRange As Range Dim oWord As Range Dim r As Long ' Parcoure notre document à modifier Set oRange = oDocTravail.Range(Start:=0, End:=oDocTravail.Characters.Count) Debug.Print oRange.Words.Count For Each oWord In oRange.Words If StrComp(Trim$(oWord.Text), Trim$(TheMot.Text), vbTextCompare) = 0 Then ' Mot identique trouvé ' Parcoure chaque lettre et applique le même format For r = 1 To TheMot.Characters.Count With oWord.Characters(r) .Font = TheMot.Characters(r).Font .Bold = TheMot.Characters(r).Bold .Underline = TheMot.Characters(r).Underline .Italic = TheMot.Characters(r).Italic End With Next r End If Next oWord End Sub
Ne connaissant rien de la programmation des macros
Set myRange = ActiveDocument.Range(Start:=0, End:=Selection.End) For Each aWord In myRange.Words If aWord.Text = "Franklin " Then aWord.Delete Next aWord
If aWord.Text = "Franklin " Then aWord.Delete
Set oDocTravail = Documents("C:\Temp\Test format.docx")
.Font = TheMot.Characters(r).Fontsuffit à copier la forme du mot sans besoin de bold, Underline et Italic. En les supprimant, ça soulage le programme qui n'a pas à faire 2 fois la même chose.
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question