Sub ReplaceText()
Dim oSlide As Slide
Dim oShape As Shape
Dim oTxtRng As TextRange
Dim oTmpRng As TextRange
Dim strExcelFilePath As String
Dim iCounter As Integer
strExcelFilePath = ActivePresentation.Path & "\Excel_Source.xlsm"
Set EX = CreateObject("Excel.Application")
EX.Workbooks.Open FileName:=strExcelFilePath, ReadOnly:=True
iCounter = 2
NextValue = EX.Workbooks("Excel_Source.xlsm").Sheets(1).Cells(iCounter, 2)
If IsEmpty(NextValue) Then
MsgBox ("Warning! Cell B2 of 'Excel_Source.xlsm' is empty. Please check your input.")
Else
While Not IsEmpty(NextValue)
oFindThat = EX.Workbooks("Excel_Source.xlsm").Sheets(1).Cells(iCounter, 1)
ORelpaceWithThis = EX.Workbooks("Excel_Source.xlsm").Sheets(1).Cells(iCounter, 2)
For Each oSlide In Application.ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.HasTextFrame Then
Set oTxtRng = oShape.TextFrame.TextRange
Set oTmpRng = oTxtRng.Replace(oFindThat, ORelpaceWithThis)
Do While Not oTmpRng Is Nothing
Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length, oTxtRng.Length)
Set oTmpRng = oTxtRng.Replace(oFindThat, ORelpaceWithThis)
Loop
End If
Next oShape
Next oSlide
iCounter = iCounter + 1
NextValue = EX.Workbooks("Excel_Source.xlsx").Sheets(1).Cells(iCounter, 2)
Wend
End If
EX.Quit
End Sub