Consulting

Results 1 to 11 of 11

Thread: find/replace fonts macro

  1. #1

    Unhappy 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

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  4. #4
    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

  5. #5
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

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

    anyway thx a lot

  7. #7
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Remove the .Select line
    Greg

    Visit my website: http://gregmaxey.com

  8. #8
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  9. #9
    Dear Greg, as always i don't have enough words to thank you

  10. #10
    VBAX Regular
    Joined
    Mar 2020
    Posts
    79
    Location
    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 View Post
    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

  11. #11
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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)
    Last edited by macropod; 03-27-2020 at 05:09 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •