Microsoft Office Forums - View Single Post - "If it's a red bolded space, highlight it" macro?

leaning · 06-25-2017, 06:51 AM

I tried this code to find all the red-bold-spaces and replace with them with @'s so I can then go back through, search for @, and delete them one by one. It will put @'s between words instead of just looking for the spaces before and after the phrases, but it's better than nothing. But it keeps giving me a "Specified value out of range" error.
I'm stumped.

Code:

Sub FindReplaceAll()
'PURPOSE: Find & Replace text/values throughout entire PowerPoint presentation
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim sld As Slide
Dim shp As Shape
Dim ShpTxt As TextRange
Dim TmpTxt As TextRange
Dim FindWord As Variant
Dim ReplaceWord As Variant

FindWord = " "
ReplaceWord = "@"

'Loop through each slide in Presentation
  For Each sld In ActivePresentation.Slides
    
    For Each shp In sld.Shapes
    If shp.HasTextFrame Then
      'Store shape text into a variable
        Set ShpTxt = shp.TextFrame.TextRange
      
      'Ensure There is Text To Search Through
        If ShpTxt <> "" Then
  If ShpTxt.Font.Bold = msoTrue And oTxtRng.Font.Color = vbRed Then
          'Store text into a variable
            Set ShpTxt = shp.TextFrame.TextRange
          
          'Find First Instance of "Find" word (if exists)
            Set TmpTxt = ShpTxt.Replace( _
             FindWhat:=FindWord, _
             Replacewhat:=ReplaceWord, _
             WholeWords:=True)
      
          'Find Any Additional instances of "Find" word (if exists)
            Do While Not TmpTxt Is Nothing
              Set ShpTxt = ShpTxt.Characters(TmpTxt.Start + TmpTxt.Length, ShpTxt.Length)
              
              Set TmpTxt = ShpTxt.Replace( _
               FindWhat:=FindWord, _
               Replacewhat:=ReplaceWord, _
               WholeWords:=True)
            Loop
          End If
        End If
        End If
    Next shp
      
  Next sld
MsgBox "Done"
End Sub