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.2859428594
:help


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