Find & Replace Multiple Strings with VBA - Help with this macro?

Question

Hello,

I'm looking to find and replace a list of words in a powerpoint full of queen's English words (Analyze = Analyse, Capitalize = Capitalise, etc) and replace them with their American English counterparts.  Here is what I've been using so far:

Sub us_qe()

     Dim oSld As Slide

     Dim oShp As Shape

     Dim otxtTemp As TextRange

     Dim otxtR As TextRange

     Dim strFindWhat As String

     Dim strReplaceWith  As String

     strFindWhat = "Analyze"

     strReplaceWith = "analyse"

     For Each oSld In ActivePresentation.Slides

     ActiveWindow.View.GotoSlide oSld.SlideIndex

     For Each oShp In oSld.Shapes

     If oShp.HasTextFrame Then

     If oShp.TextFrame.HasText Then

     Set otxtR = oShp.TextFrame.TextRange

     Set otxtTemp = oShp.TextFrame.TextRange.Find(strFindWhat, 0, False, True)

     Do While Not otxtTemp Is Nothing

     otxtTemp.Select

     If MsgBox("Replace " & strFindWhat & " with " & strReplaceWith & "?", vbYesNo) = vbYes Then otxtTemp.Text = strReplaceWith

     Set otxtTemp = otxtR.Find(strFindWhat, otxtTemp.Start + otxtTemp.Length, False, True)

     Loop

     End If

     End If

     Next oShp

     Next oSld

End Sub

This works great for one word.  Takes me to the word, asks if I want to replace it, and does so.  I have a few questions here:

1.  I don't think this is the right start to go about replacing a list?  Array("word 1", "word 2") isn't working at least.  I have a list of 30+ words to look for.

2.  I'm hoping to keep the case the same, i.e if it finds "Analyse" change to "Analyze" and "analyse" to "analyze".  Not sure if MatchCase:=True works here or not

3.  I want the macro to search in shapes and tables as well as text boxes.

I have minimal VBA knowledge but would greatly appreciate anyone who takes the time to help!

Thanks!!!

Answer 1

I've noticed similar problems with select before. It only happen sometimes and I have no idea why.

Maybe try making the textrange (temporarily) BOLD or Italic instead

You could also try this illogical method - Select any shape on slide one before running the macro each time. Seems to help and I have no idea why.

Answer 2

This seems to be working great so far, thank you!  For some reason, however otxtTemp.Select seems to only be selecting the words it's replacing on some run throughs of the code.  Is there any reason for that in my code?  Here's what I have so far:

Sub us_qe2()

 Dim oSld As Slide

 Dim oShp As Shape

 Dim otxtTemp As TextRange

 Dim otxtR As TextRange

 Dim strFindWhat As String

 Dim strReplaceWith  As String

 Dim rayUS() As String

 Dim rayUK() As String

 Dim L As Long

 rayUS = Split(Expression:="Annualize/annualisze/Analyze/analyze/Capitalize/capitalize/etc", Delimiter:="/")

 rayUK = Split(Expression:="Annualise/annualise/Analyse/analyse/Capitalise/capitalise/etc", Delimiter:="/")

 If UBound(rayUS) <> UBound(rayUK) Then

 MsgBox "Check the data!"

 Exit Sub

 End If

 For L = 0 To UBound(rayUS)

 strFindWhat = rayUS(L)

  strReplaceWith = rayUK(L)

For Each oSld In ActivePresentation.Slides

 ActiveWindow.View.GotoSlide oSld.SlideIndex

 For Each oShp In oSld.Shapes

 If oShp.HasTextFrame Then

      If oShp.TextFrame.HasText Then

      Set otxtR = oShp.TextFrame.TextRange

      Set otxtTemp = oShp.TextFrame.TextRange.Find(strFindWhat, 0, True, False)

      Do While Not otxtTemp Is Nothing

      otxtTemp.Select

      If MsgBox("Replace " & strFindWhat & " with " & strReplaceWith & "?", vbYesNo) = vbYes Then otxtTemp.Text = strReplaceWith

      Set otxtTemp = otxtR.Find(strFindWhat, otxtTemp.Start + otxtTemp.Length, True, False)

      Loop

      End If

      End If

      Next oShp

      Next oSld

 Next L

MsgBox "US replaced with QE"

End Sub

Answer 3

Your code should already search shapes and Shyam's page should show you how to search tables etc.

You should be able to use arrays to supply the words (with case variations)

This may not be the most efficient way to do it but it should work: (Top of head code)

Sub us_qe()

Dim oSld As Slide

Dim oShp As Shape

Dim otxtTemp As TextRange

Dim otxtR As TextRange

Dim strFindWhat As String

Dim strReplaceWith  As String

Dim rayUS() As String

Dim rayUK() As String

Dim L As Long

rayUS = Split(Expression:="Analyze/analyze/Capitalize/capitalize/etc", Delimiter:="/")

rayUK = Split(Expression:="Analyse/analyse/Capitalise/capitalise/etc", Delimiter:="/")

If UBound(rayUS) <> UBound(rayUK) Then

MsgBox "Check the data!"

Exit Sub

End If

For L = 0 To UBound(rayUS)

strFindWhat = rayUS(L)

strReplaceWith = rayUK(L)

For Each oSld In ActivePresentation.Slides

ActiveWindow.View.GotoSlide oSld.SlideIndex

For Each oShp In oSld.Shapes

'REPLACE CODE HERE Match case should be TRUE

Next oShp

Next oSld

Next L

End Sub

Answer 4

There is working example on this page: Global Find And Replace routine in PowerPoint (http://skp.mvps.org/ppt00025.htm#2) With some additions you should be able to modify it to suit your needs.