find/replace fonts macro

Hi all,

i was wondering if is it possible to create a macro to find and replace all fonts on a word document but don't apply that replacement to specific font

for ex.

select all text on file and make it (Arial) but don't apply that to text who takes (Symbol) font name



Thanks

Might take a little while:

Code:

---

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oChr As Range
  For Each oChr In ActiveDocument.Range.Characters
    If Not oChr.Font.Name = "Symbol" Then oChr.Font.Name = "Arial"
  Next
lbl_Exit:
  Exit Sub
End Sub

---

This might be faster didn't test:

Code:

---

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range
  Set oRng = ActiveDocument.Range
  With oRng
    .Collapse wdCollapseStart
    Do
      Do While .Characters.Last.Font.Name <> "Symbol" And .End <> ActiveDocument.Range.End
      .MoveEnd wdCharacter, 1
      Loop
      .MoveEnd wdCharacter, -1
      .Font.Name = "Arial"
      .Collapse wdCollapseEnd
      .MoveEnd wdCharacter, 1
      Do While .Characters.Last.Font.Name = "Symbol" And .End <> ActiveDocument.Range.End
        .MoveEnd wdCharacter, 1
        .Select
      Loop
      .MoveEnd wdCharacter, -1
      .Collapse wdCollapseEnd
    Loop Until .End = ActiveDocument.Range.End - 1
  End With
lbl_Exit:
  Exit Sub
End Sub

---

WOW it is amazing and working great, please can you tell me what line to
adjust if i want to add one more skipped font with (Symbol)



for ex:



ignore (Symbol) & (Tahoma) then replace the rest to Arial





Thanks a lot for your generous help

You are moving the goal post after the start of the game!

Code:

---

Sub ScratchMacro()
    'A basic Word macro coded by Greg Maxey
    Dim oRng As Word.Range
    Set oRng = ActiveDocument.Range
    With oRng
        .Collapse wdCollapseStart
        Do
            Do While .Characters.Last.Font.Name <> "Symbol" And .Characters.Last.Font.Name <> "Tahoma" And .End <> ActiveDocument.Range.End
                .MoveEnd wdCharacter, 1
            Loop
            .MoveEnd wdCharacter, -1
            .Font.Name = "Arial"
            .Collapse wdCollapseEnd
            .MoveEnd wdCharacter, 1
            Do While .Characters.Last.Font.Name = "Symbol" Or .Characters.Last.Font.Name = "Tahoma" And .End <> ActiveDocument.Range.End
                .MoveEnd wdCharacter, 1
                .Select
            Loop
            .MoveEnd wdCharacter, -1
            .Collapse wdCollapseEnd
        Loop Until .End = ActiveDocument.Range.End - 1
    End With
lbl_Exit:
    Exit Sub
End Sub

---

Thanks a lot Greg, works like magic
but don't know why it slows down application and sometimes crashes.

anyway thx a lot

Remove the .Select line

If you have not used any colored fonts in your document then this might be much faster:

Code:

---

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Word.Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.Name = "Symbol"
    .Replacement.Font.ColorIndex = wdBrightGreen
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.Name = "Tahoma"
    .Replacement.Font.ColorIndex = wdBrightGreen
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.ColorIndex = wdAuto
    .Replacement.Font.Name = "Arial"
    .Execute Replace:=wdReplaceAll
  End With
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.ColorIndex = wdBrightGreen
    .Replacement.Font.ColorIndex = wdAuto
    .Execute Replace:=wdReplaceAll
  End With
lbl_Exit:
  Exit Sub
End Sub

---

Dear Greg, as always i don't have enough words to thank you :)

How do I change the code to only apply to the footnotes?
It does work for my needs in the main text.

Quote:

---

Originally Posted by gmaxey

You are moving the goal post after the start of the game!

Code:

---

Sub ScratchMacro()
    'A basic Word macro coded by Greg Maxey
    Dim oRng As Word.Range
    Set oRng = ActiveDocument.Range
    With oRng
        .Collapse wdCollapseStart
        Do
            Do While .Characters.Last.Font.Name <> "Symbol" And .Characters.Last.Font.Name <> "Tahoma" And .End <> ActiveDocument.Range.End
                .MoveEnd wdCharacter, 1
            Loop
            .MoveEnd wdCharacter, -1
            .Font.Name = "Arial"
            .Collapse wdCollapseEnd
            .MoveEnd wdCharacter, 1
            Do While .Characters.Last.Font.Name = "Symbol" Or .Characters.Last.Font.Name = "Tahoma" And .End <> ActiveDocument.Range.End
                .MoveEnd wdCharacter, 1
                .Select
            Loop
            .MoveEnd wdCharacter, -1
            .Collapse wdCollapseEnd
        Loop Until .End = ActiveDocument.Range.End - 1
    End With
lbl_Exit:
    Exit Sub
End Sub

---

---

Change:
Set oRng = ActiveDocument.Range
to:
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)

You'll also need to change the other references for:

ActiveDocument.Range

to:

ActiveDocument.StoryRanges(wdFootnotesStory)