Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA

ckcs

New Member
Joined
Jan 14, 2023
Messages
1
Office Version
  1. 2016
Platform
  1. Windows
I've looked around and haven't managed to find and/or put together what I'm looking for.
I've made a "template" using text(number/letter/words/symbolss) on PowerPoint as follows:

tmpltePPT.png


The same text (numbers in this case) has been inserted into column A in Excel - the Find column.
The text (words) in column B - text to replace with.

ExlFnR.png





My main aim is to compare an array of cells ("A1", "A2", "A3"...) to the input in a Slide and then replace with another array of cells ("B1", "B2", "B3"...) depending on if they match resulting in:

RsltPPT.png





So far, I've managed to get VBA on Excel to open the PowerPoint Presentation through part of the following code:
Rich (BB code):
Set myPresentation = PowerPointApp.Presentations.Add
    Set myPresentation = PowerPointApp.Presentations.Open("C:\Users\ctefy\Desktop\Dtvs\Trl\RndTs.pptx")


Even managed to get the first two replacement words to copy over to only one slide using:

Rich (BB code):
Sub PasteMultipleSlides()

'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: www.TheSpreadsheetGuru.com

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long

'Create an Instance of PowerPoint
  On Error Resume Next

    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")

    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then Exit
      If PowerPointApp Is Nothing Then
        MsgBox "PowerPoint Presentation is not open, aborting."
        Exit Sub
      End If

    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Open the Presentation
    Set myPresentation = PowerPointApp.Presentations.Open("INSERT FILE PATH HERE")

'List of PPT Slides to Paste to
  MySlideArray = Array(2, 3, 4, 5, 6)

'List of Excel Ranges to Copy from
    MyRangeArray = Array(Range("A1"), Range("A2"), Range("A3"), Range("A4"), Range("A5"))

'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)
    'Copy Excel Range
        MyRangeArray(x).Copy

    'Paste to PowerPoint and position
      On Error Resume Next
        Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=7) 'Excel 2007-2010
        Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
      On Error GoTo 0

    'Center Object
      With myPresentation.PageSetup
        shp.Left = 30
        shp.Top = 29
      End With

  Next x

'Transfer Complete
  Application.CutCopyMode = False
  ThisWorkbook.Activate
  MsgBox "Complete!"

End Sub

Original source:
VBA Copy/Paste Multiple Excel Ranges To PowerPoint Slides

Closest edit of source I've found:
VBA: Populate array from range with range coordinates?

What I come across with the above is an error stating:
"Invalid or unqualified reference."
Regardless, it was a few of my trial and errors which didn't give the results expected



Rich (BB 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

Source:
Find/Replace in PPT via Excel VBA

And again in this version above I tried to compare the question and the answer however couldn't find the right variables.



Additional things I've considered (if possible to request)
- Would it be better to split the text templates for the slide on different sheets?
(i.e slide(1) would refer to find and replace on sheet1
slide(2) would refer to find and replace on sheet2
slide(3) would refer to find and replace on sheet3
etc)
- Would it be possible to have the replaced text keep the font and color from Excel but keep within the size of the text template in PowerPoint?
- If one of the arrays do not match then only that one is ignored/skipped if possible - otherwise do not continue.
- Max of approx 70 text inputs and arrays to be found/compared (approx. amount might not reach that much)

Finally, :')
I'm fairly new to using Microsoft Applications and though I've spent a lot more time using Google Apps, Microsoft has plenty to offer.
Anyhow, please let me know if there's anything that needs more explaining.

Thanks.
p.s - have tried inputting tags #vba and #powerpoint/#ppt, however are unavailable.
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

Forum statistics

Threads
1,214,925
Messages
6,122,298
Members
449,077
Latest member
Rkmenon

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
Back
Top