VBA Find/Replace Array Help - Almost there!

[jcolliu]

I'm very close to being complete with this macro. This is a macro that opens and scans a PowerPoint selected by the user and replaces all American English words with their Queen's English counterparts. (Analyze -> Analyse, Labor -> Labour). Highlights and prompts the user before each replace and notifies when done. What I'm hoping to do at this point is replace the static arrays I've written in the macro with two columns in my workbook. It works great as is, but I feel like there's a better way than to write out every word in the array as I have it now.

Basically:

In the PowerPoint file, if it finds a value within "B3:B116", replace with the corresponding value in "C3:C116".

Sub US_QE()

'Open PowerPoint Document from Excel

Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose PowerPoint")

If strFileToOpen = False Then
    MsgBox "No file selected.", vbExclamation, "Sorry!"
    GoTo Ending
End If

objPPT.Presentations.Open Filename:=strFileToOpen

'PowerPoint Variables

Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.presentation
Dim fnd As Variant
Dim rplc As Variant
Dim FindArray As Variant
Dim ReplaceArray As Variant
Dim TxtRng As PowerPoint.TextRange
Dim TmpRng As PowerPoint.TextRange
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
[COLOR="#FF0000"]
'WORKING ON PULLING FROM EXCEL
'Dim rg As Range
'Dim rg2 As Range
'Set rg1 = ThisWorkbook.Worksheets("Sheet1").Range("B3:B116")
'Set rg2 = ThisWorkbook.Worksheets("Sheet1").Range("C3:C116")[/COLOR]

'Find/Replace Variables
  FindArray = Array("analyze", "Analyze", "annualize", "Annualize", "annualize", "Capitalize", "capitalize", "nationalize", "Nationalize", "capitalization", "Favor", "favor", "Labor", "labor")
  ReplaceArray = Array("analyse", "Analyse", "annualise", "Annualise", "annualise", "Capitalise", "capitalise", "nationalise", "Nationalise", "capitalisation", "Favour", "favour", "Labour", "labour")
                        
'Loop Through Each Slide
  For Each sld In objPPT.ActivePresentation.Slides
  objPPT.Activate
  objPPT.ActiveWindow.View.GotoSlide sld.SlideIndex
      For y = LBound(FindArray) To UBound(FindArray)
        For Each shp In sld.Shapes
            
        fnd = FindArray(y)
        rplc = ReplaceArray(y)
        
        If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
          
                Set TxtRng = shp.TextFrame.TextRange.Find(fnd, 0, True, WholeWords:=msoFalse)
                If TxtRng Is Nothing Then GoTo NextTxtRng
                TxtRng.Select
                
                 AppActivate Application.Caption
                 If MsgBox("Replace " & fnd & " with " & rplc & "?", vbYesNo + vbSystemModal) = vbYes Then Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
                 ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=True)
              
              End If
        End If
        
'Replace Other Instances (if necessary)
          Do While Not TmpRng Is Nothing
            Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
              ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=False)
          Loop

'If Text Range is Nothing:
NextTxtRng:
        Next shp
      Next y
    Next sld
                 
AppActivate Application.Caption
MsgBox "US replaced with QE"

'If no PowerPoint selected:
Ending:
End Sub

Any insight here? Thank you!

 

[V_Malkoti]

Since your array variables are declared as Variant, assigning ranges directly to them should automatically convert ranges as arrays. Which means that you can use your remaining code as is.

FindArray = ThisWorkbook.Worksheets("Sheet1").Range("B3:B116")
ReplaceArray = ThisWorkbook.Worksheets("Sheet1").Range("C3:C116")

 

[jcolliu]

After I do this, I'm not sure what to do with the , as far as setting the LBound/Ubound and having it cycle through each in the array. I get a subscript out of range error if I simply change the arrays to the above.

 

[V_Malkoti]

My bad. I didn't remember that variant arrays created from range are always two dimensional. You can convert them to a single dimension using Transpose method.

FindArray = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("B3:B116"))
ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("C3:C116"))

 

[jcolliu]

Dude.

You are the man. This works perfectly.

Minor follow up - Is there any way to stream line this to run more smoothly? It's browsing the document at a much slower pace now as I can imagine it's sifting through 100 cells for each shape on the PowerPoint. Not a huge deal, just wondering if there's a way to clean up my code to let it work more efficiently.

 

[V_Malkoti]

Well a few standard things you can try:

1. Turn off screen updates while code is running (Application.ScreenUpdating = False at beginning and True at the end of code)
2. Do not use Range.select, Sheet.activate (to use activecell etc)
3. Reduce nested loop levels

Then to identify actual time consuming statments you can place Timer statements in the code to calculate time taken, and then slowly narrow down the area of investigation. Or execute manually using F8 and see which statements take longest.

 

[jcolliu]

It's really coming together, thanks so much for the help. I'm just double checking the script to make sure everything works, and it looks like I'm able to recreate this error pretty often: When the same word exists in the same shape multiple times, it only picks up the word the first time. I think maybe my "REPLACE OTHER INSTANCES" section might not be working as it should? It's highlighted below for visibility - can anyone comment?

Sub US_QE()

'VARIABLES
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.presentation
Dim fnd As Variant
Dim rplc As Variant
Dim FindArray As Variant
Dim ReplaceArray As Variant
Dim TxtRng As PowerPoint.TextRange
Dim TmpRng As PowerPoint.TextRange
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim objPPT As Object

'PROMPT USER TO OPEN POWERPOINT DOC
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

AppActivate Application.Caption
strFileToOpen = Application.GetOpenFilename _
(Title:="Please Choose PowerPoint for US - QE Conversion")

If strFileToOpen = False Then
    MsgBox "No file selected.", vbExclamation, "Sorry!"
    GoTo Ending
End If

objPPT.Presentations.Open Filename:=strFileToOpen

'PULLING ARRAY FROM EXCEL
FindArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("B3:B64"))
ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("Conversion").Range("C3:C64"))

'LOOP THROUGH EACH SLIDE
For Each sld In objPPT.ActivePresentation.Slides
objPPT.Activate
objPPT.ActiveWindow.View.GotoSlide sld.SlideIndex
    For y = LBound(FindArray) To UBound(FindArray)
    For Each shp In sld.Shapes
    fnd = FindArray(y)
    rplc = ReplaceArray(y)
       
        If shp.HasTextFrame Then
        If shp.TextFrame.HasText Then
            Set TxtRng = shp.TextFrame.TextRange.Find(fnd, 0, True, WholeWords:=msoFalse)
                If TxtRng Is Nothing Then GoTo NextTxtRng
                TxtRng.Select
                 
                AppActivate Application.Caption
                If MsgBox("Replace " & fnd & " with " & rplc & "?", vbYesNo + vbSystemModal) = vbYes _
                Then Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
                ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=True)
                                          
        End If
        End If
        
[COLOR="#FF0000"]'REPLACE OTHER INSTANCES[/COLOR]
          Do While Not TmpRng Is Nothing
            Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
              ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=False)
          Loop
          
'IF TEXT RANGE IS NOTHING (NO VALUE FOUND)
NextTxtRng:
Next shp
Next y
Next sld
                 
AppActivate Application.Caption
MsgBox "US replaced with QE"

'IF NO POWERPOINT SELECTED
Ending:
End Sub

 

[V_Malkoti]

Have you tried debugging the code to see if that's true - do while loop is not executing?

On a side note, I see that in do while loop you have case matching turned off, but in other two places (TextRange.Find and TxtRange.Replace) searching is case sensitive. Shouldn't that be consistent across all text search statements?