Find/Replace in PPT via Excel VBA

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
85
Office Version
  1. 365
I found this bit of code on the forums, and it does a great job of replacing the first instance of a tag, but does not replace the second.

For instance if I have <<customername>> in the PPT, I have a cell with John Doe in Excel that overwrites that tag.

But if I have a second instance of <<customername>> in the PPT, it does not get replaced.

Is there any way to do that via VBA?

My code below:

VBA Code:
'**********************START PPT COVER SLIDE POPULATION
With ThisWorkbook.Sheets("PPTRecapData")
    'PROMPT USER TO OPEN POWERPOINT DOC
   Set objPPT = CreateObject("PowerPoint.Application")
   objPPT.Visible = True
    
    'PULLING ARRAY FROM EXCEL
    FindArray = Application.Transpose(ThisWorkbook.Worksheets("PPTRecapData").Range("A2:A13"))
    ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("PPTRecapData").Range("B2:B13"))
    
    '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
                        Set TmpRng = TxtRng.Replace(FindWhat:=fnd, _
                        ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=True)
                End If
            End If
            
     'THIS IS THE CODE THAT WAS SUPPOSED TO REPLACE EXTRA INSTANCES
              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 "Cover Page Population Done!"
    
    'IF NO POWERPOINT SELECTED
Ending:
End With
'**********************END PPT COVER SLIDE POPULATION
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
791
Office Version
  1. 365
Platform
  1. Windows
Hi - so I tried your code, and save for a few errors (likely because it was dealing with a presentation it wasn't designed to), it worked fine for me. I nonetheless tried rejigging the code - I'm not sure if it will help, but perhaps try it out on a copy of the presentation and see how it goes? (You don't want to damage the files you have in case anything goes horribly wrong... you can't undo a VBA process!)

I've tried keeping in as much as the original code in because I suspect that what you've posted is not the code in its entirety. I've put code in that might conflict with your own (for example, Dim objPPT as Object should not be in there twice - feel free to delete the line in my code if you get an error message). The revised code worked for me - it replaced 8 test words with misspellings of the same words (and back again) spread multiple times in different 'shapes' on different slides. Let me know if you encounter any problems and I'll see what I can do to solve it.

VBA Code:
Sub ReplacePowerpoint()        ' <- You may want to delete this

'**********************START PPT COVER SLIDE POPULATION

    'PULLING ARRAY FROM EXCEL
    FindArray = Application.Transpose(ThisWorkbook.Worksheets("PPTRecapData").Range("A2:A13"))
    ReplaceArray = Application.Transpose(ThisWorkbook.Worksheets("PPTRecapData").Range("B2:B13"))
    
    'PROMPT USER TO OPEN POWERPOINT DOC
    Dim objPPT As Object
    Set objPPT = CreateObject("PowerPoint.Application")
    objPPT.Visible = True
        
    'LOOP THROUGH EACH SLIDE
    For Each sld In objPPT.activepresentation.slides
        For Y = LBound(FindArray) To UBound(FindArray)
            fnd = FindArray(Y)
            rplc = ReplaceArray(Y)
            For Each shp In sld.Shapes
                If shp.HasTextFrame Then
                    If shp.TextFrame.HasText Then
                        Set TxtRng = shp.TextFrame.TextRange.Find(fnd, 0, True, WholeWords:=msoFalse)
                        If Not TxtRng Is Nothing Then
                            Do
                                Set tmprng = TxtRng.Replace(FindWhat:=fnd, ReplaceWhat:=rplc, WholeWords:=False, MatchCase:=False)
                            Loop While Not tmprng Is Nothing
                        End If
                    End If
                End If
            Next shp
        Next Y
    Next sld
                     
    AppActivate Application.Caption
    MsgBox "Cover Page Population Done!"
    
    'IF NO POWERPOINT SELECTED
Ending:
'**********************END PPT COVER SLIDE POPULATION

End Sub                           ' <- You may want to delete this
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,699
Messages
5,766,002
Members
425,322
Latest member
galaxy6623top

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top