VBA excel code to change links source in Powerpoint (charts and data tables)

[Secret Chimpanzee]

Hi there,

I have a Powerpoint pack that contains linked charts and data tables from more than one Excel source. New iterations of the Excel sources are usually saved down each month and the links in the PPT pack need to be changed accordingly.

I need some code that will change the link sources by looping through 2 excel columns to find the old file path (column D) and the new file path (column E).

Thanks in advance

 

[Secret Chimpanzee]

I found this code that looks like it might be able to do what I need but I'm unable to get it to run, I keep getting Error 429 - ActiveX can't create object - whenever it gets to the stage where it opens the powerpoint file.

Anyone have any ideas?

Sub ChangeOLELinks()

Dim ppApp As Object
Dim oSld As Slide
Dim oSh As Shape
Dim sOldPath As String
Dim sNewPath As String
Dim sourceFile As Variant

Set ppApp = CreateObject("PowerPoint.Application")

sourceFile = Application.GetOpenFilename(Title:="Select file", _
    filefilter:="Powerpoint files *.ppt*(*.ppt*),")
    
ppApp.Presentations.Open fileName:=sourceFile, ReadOnly:=msoFalse

sOldPath = ThisWorkbook.Sheets("Update Links").Range("D3").Value
sNewPath = ThisWorkbook.Sheets("Update Links").Range("E3").Value

On Error GoTo ErrorHandler

For Each oSld In ActivePresentation.Slides
    For Each oSh In oSld.Shapes
        ' Change only linked OLE objects
        If oSh.Type = msoLinkedOLEObject Then
            On Error Resume Next
            ' Verify that file exists
            If Len(Dir$(Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath))) > 0 Then
                 oSh.LinkFormat.SourceFullName = Replace(oSh.LinkFormat.SourceFullName, sOldPath, sNewPath)
            Else
                  MsgBox ("File is missing; cannot relink to a file that isn't present")
            End If
            On Error GoTo ErrorHandler
         End If
    Next    ' shape
Next    ' slide

MsgBox ("Done!")

NormalExit:
Exit Sub
ErrorHandler:
MsgBox ("Error " & Err.Number & vbCrLf & Err.Description)
Resume NormalExit

End Sub