Find/Replace in PPT via Excel VBA

[noslenwerd]

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:

'**********************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

 

[Dan_W]

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.

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