VBA for Find and Replace a string of text

[rwc1023]

Hello experts-
hoping someone can help with VBA to do find and replace a string of text on all slides, including shapes and boxes:

I need to do this:

Find "June 2021" replace with "July 2021"
Find "Aug 2021" replace with "Sept 2021"
Find "Oct 2021" replace with "Nov 2021"
Find "Dec 2021" replace with "Jan 2022"

thank you!

[Paul_Hossler]

Here's what I've been using - it covers the cases I usually have

When something new comes up, I just expand it

Sub drv()


    Call pvtReplaceText("zzzzzzzz", "12345678", True)


End Sub


'http://skp.mvps.org/ppt00025.htm#2
Sub pvtReplaceText(sOld As String, sNew As String, Optional bWholeWord As Boolean = False)
    
    Dim oSlide As Slide
    Dim oShape As Shape
    Dim oText As TextRange
    Dim oTemp As TextRange
    
    For Each oSlide In ActivePresentation.Slides


        For Each oShape In oSlide.Shapes
            Call pvtReplaceText1(oShape, sOld, sNew, bWholeWord)
        Next oShape
    
    Next oSlide


End Sub




Private Sub pvtReplaceText1(oShape As Object, FindString As String, ReplaceString As String, Optional bWholeWord As Boolean = False)
    Dim oText As TextRange
    Dim oTemp As TextRange
    Dim i As Long, iRows As Long, iCols As Integer
    Dim oShapeTmp As Shape
 
    Select Case oShape.Type
    
        Case msoPlaceholder
            Call pvtText(oShape, FindString, ReplaceString, bWholeWord)
            If oShape.HasTable Then
                Call pvtTable(oShape.Table, FindString, ReplaceString, bWholeWord)
            End If
            If oShape.HasSmartArt Then
                Call pvtSmartArt(oShape.SmartArt, FindString, ReplaceString)
            End If
        
        Case msoTable
            Call pvtTable(oShape.Table, FindString, ReplaceString, bWholeWord)
        
        Case msoGroup    'Groups may contain shapes with text, so look within it
            For i = 1 To oShape.GroupItems.Count
                Call pvtReplaceText1(oShape.GroupItems(i), FindString, ReplaceString)
            Next i
        
        Case msoDiagram
            Call pvtNodes(oShape.Diagram, FindString, ReplaceString)
            
        Case msoSmartArt
            Call pvtSmartArt(oShape.SmartArt, FindString, ReplaceString)
            
        Case Else
            Call pvtText(oShape, FindString, ReplaceString, bWholeWord)
        End Select
End Sub




Private Sub pvtTable(oTable As Table, FindString As String, ReplaceString As String, Optional bWholeWord As Boolean = False)
    Dim iRows As Long, iCols As Integer
    Dim oShapeTmp As Shape
    
    With oTable
        For iRows = 1 To .Rows.Count
            For iCols = 1 To .Rows(iRows).Cells.Count
                Set oShapeTmp = .Rows(iRows).Cells(iCols).Shape
                Call pvtText(oShapeTmp, FindString, ReplaceString, bWholeWord)
            Next
        Next
    End With
End Sub




Private Sub pvtText(oShape As Shape, FindString As String, ReplaceString As String, Optional bWholeWord As Boolean = False)
    Dim oTextRange As TextRange, oTextRangeTemp As TextRange
    Dim i As Long


    With oShape
            
        If Not .HasTextFrame Then Exit Sub
        If Not .TextFrame.HasText Then Exit Sub
                    
         Set oTextRange = .TextFrame.TextRange
         Set oTextRangeTemp = oTextRange.Replace(FindWhat:=FindString, Replacewhat:=ReplaceString, WholeWords:=bWholeWord)
         Do While Not oTextRangeTemp Is Nothing
             Set oTextRangeTemp = oTextRange.Replace(FindWhat:=FindString, Replacewhat:=ReplaceString, WholeWords:=bWholeWord)
         Loop
     
         For i = 1 To oTextRange.Paragraphs.Count
             Set oTextRange = oTextRange.Paragraphs(i)
             oTextRange.Text = Trim(oTextRange.Text)
             oTextRange.Characters(1, 1) = UCase(oTextRange.Characters(1, 1))
         Next i
    End With
End Sub


Private Sub pvtNodes(oDiagram As Diagram, FindString As String, ReplaceString As String)
    Dim i As Long
    
    With oDiagram
        For i = 1 To .Nodes.Count
            Call pvtText(.Nodes(i).TextShape, FindString, ReplaceString)
        Next i
    End With
End Sub


Private Sub pvtSmartArt(oSmartart As SmartArt, FindString As String, ReplaceString As String)
    Dim i As Long
    Dim s As String
    
    With oSmartart
        For i = 1 To .Nodes.Count
            s = .AllNodes(i).TextFrame2.TextRange.Text
            .AllNodes(i).TextFrame2.TextRange.Text = Replace(s, FindString, ReplaceString)
        Next i
    End With
End Sub

[rwc1023]

Hi Paul!
thank you so much!! one follow up question.
how do I adjust the VBA to look for whole word?
what do I need to change? thanks!!

[Paul_Hossler]

My understanding is that the .TextRange.Replace object allows a 'Whole Word' parameter, but the VBA Replace doesn't

So in the main

Sub pvtReplaceText(sOld As String, sNew As String, Optional bWholeWord As Boolean = False)

the bWholeWord flag is pass to everything that can use it


Any eamples?

[rwc1023]

Hi Paul - ok it is working.
How about an OR statement. for example, Find "puppy" or "doggie" replace with "dog"?
i expanded your original with 7 other finds but it looks like I will need to have the OR in some of them. thank you!!

[Paul_Hossler]

I'd just call pvtReplaceText () two times

Sub drv()
    Call pvtReplaceText("puppy", "dog", True)
    Call pvtReplaceText("doggie", "dog", True)
End Sub

[rwc1023]

Hi Paul,
sorry to ask one more question here. after running your codes, the VBA randomly added four extra blank lines to text content of some of the slides and those slides do not have any of the text i am looking for. It is very strange. it looks random but i am sure its got to be the codes.
Any idea?

thank you!

I'd just call pvtReplaceText () two times

Sub drv()
    Call pvtReplaceText("puppy", "dog", True)
    Call pvtReplaceText("doggie", "dog", True)
End Sub

[Paul_Hossler]

Attach a small presentation with 2-3 slides that show it along with your macro

[rwc1023]

Thanks Paul. Please see attached sample slides with the Macro.

Once I run the Find Replace macro, the macro added extra lines to the slides where there was a replacement....very strange.Test Find and Replace.pptmTest Find and Replace.pptm

Attach a small presentation with 2-3 slides that show it along with your macro

[Paul_Hossler]

Delete these lines and it should work. I can't remember why I had them in the macro, but I must have had SOME reason at the time. Might have been some special processing I needed

'         For i = 1 To oTextRange.Paragraphs.Count
'             Set oTextRange = oTextRange.Paragraphs(i)
'             oTextRange.Text = Trim(oTextRange.Text)
'             oTextRange.Characters(1, 1) = UCase(oTextRange.Characters(1, 1))
'         Next i

[rwc1023]

Thanks Paul! that worked great!
Now how do I make this macro find and replace words in the Notes? I just realized it did not pick up the matches in the Notes. Let me know what I need to add to the codes. THANK YOU!!!

Delete these lines and it should work. I can't remember why I had them in the macro, but I must have had SOME reason at the time. Might have been some special processing I needed

'         For i = 1 To oTextRange.Paragraphs.Count
'             Set oTextRange = oTextRange.Paragraphs(i)
'             oTextRange.Text = Trim(oTextRange.Text)
'             oTextRange.Characters(1, 1) = UCase(oTextRange.Characters(1, 1))
'         Next i

[Paul_Hossler]

try the added lines

'http://skp.mvps.org/ppt00025.htm#2
Sub pvtReplaceText(sOld As String, sNew As String, Optional bWholeWord As Boolean = False)
    
    Dim oSlide As Slide
    Dim oShape As Shape
    Dim oText As TextRange
    Dim oTemp As TextRange
    
    For Each oSlide In ActivePresentation.Slides


        For Each oShape In oSlide.Shapes
            Call pvtReplaceText1(oShape, sOld, sNew, bWholeWord)
        Next oShape
    
        'added 6/17/2021
        If oSlide.HasNotesPage Then
            For Each oShape In oSlide.NotesPage.Shapes
                Call pvtReplaceText1(oShape, sOld, sNew, bWholeWord)
            Next oShape
        End If
    Next oSlide


End Sub