find/replace fonts macro

[Ethen5155]

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

[gmaxey]

Might take a little while:


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

[gmaxey]

This might be faster didn't test:


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

[Ethen5155]

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

[gmaxey]

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


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

[Ethen5155]

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

anyway thx a lot

[gmaxey]

Remove the .Select line

[gmaxey]

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


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

[Ethen5155]

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

[JPG]

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



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


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

[macropod]

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)