Loop through a PowerPoint presentation and replace certain keywords with text - excel

Question

I was hoping to get some help. I have the following code that works on replacing text from a word documents with a certain word in excel. For example I have ClientName in a cell and the Cell next to it has John, so each time the word ClientName is found it is replaced with John and so on. Here is the code that works for word documents. Can it be altered to work for .pptx too?
Sub AutoContract()
Dim cell As Range
Dim rng As Range
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim wdDoc2 As Word.Document
Dim FilePath As String
Dim FilePath2 As String
Dim ending As String
Dim rngPara As Range
Dim Prompt As String
Dim Filesave As String
Dim FileSave2 As String
On Error GoTo ErrorHandler
Set wdApp = Nothing
FilePath = ThisWorkbook.Path
FilePath2 = Left(FilePath, InStr(FilePath, "\Calculations") - 1)
Filename = "Filename.docx"
StrDoc = FilePath2 & "\Inputs" & "\" & Filename
Set wdDoc2 = wdApp.Documents.Open(StrDoc)
Set rngPara = Range("A1:Z1058").Find("Variable Parameters")
If rngPara Is Nothing Then
MsgBox "Variable Parameters column was not found."
GoTo ErrorHandler
End If
Set rng = Range(rngPara, rngPara.End(xlDown))
wdApp.Visible = True
For Each cell In rng
If cell.Value = "" Then Exit For
With wdDoc2.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = False
.Wrap = wdFindContinue
.Text = cell.Value
.Replacement.Text = cell.Offset(0, 1)
.Execute Replace:=wdReplaceAll
End With
Next
SaveAsName = Left(FilePath, InStr(FilePath, "\Calculations") - 1) & "\Outputs\" & Range("EmployName").Value & " " & Range("TodayDate").Value & " Contract" & ".docx"
wdDoc2.SaveAs2 SaveAsName
ErrorExit:
Set wdApp = Nothing
Exit Sub
ErrorHandler:
If Err.Number = 5174 Then
MsgBox "Please check the file name you specified is correct."
Resume ErrorExit
Else
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wdApp Is Nothing Then
wdApp.Quit False
End If
Resume ErrorExit
End If
End Sub