Batch find and replace texts in powerpoint ?

[WHharris]

Hello everyone !

I have Thousands of PPT files，I want to find a Macro , to find and replace some texts in these ppt files.

I found this Macro (below), but this only work for one file ，Besides，it didnt work for some texts in group,

Is anyone can help me ?
My English is not very good


Hello everyone !

I have Thousands of PPT files，I want to find a Macro , to find and replace some texts in these ppt files.
I found this Macro (below), but this only work for one file ，Besides，it didnt work for some texts in group,
Is anyone can help me ? My English is not very good

Sub Multi_FindReplace()
    ' PURPOSE: Find & Replace a list of text/values throughout entire PowerPoint presentation
    ' INSERT THE LIST OF MERGE FIELDS HERE
    Dim FindList As Variant
    FindList = Array("word1", "word2", "word3")
    ' INSERT THE LIST OF VARIABLES TO BE INSERTED BY HERE
    Dim ReplaceList As Variant
    ReplaceList = Array("word1.1", "word2.1", "word3.1")
    ' Loop through each slide in Presentation
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        Dim shp As Shape
        For Each shp In sld.Shapes
            ' for tables
            If shp.HasTable Then
                ReplaceWordsInTable shp, FindList, ReplaceList
            ElseIf shp.HasTextFrame Then
                ReplaceWordsInTextFrame shp, FindList, ReplaceList
            Else
                '--- doing nothing for all other shapes (at this time)
            End If
        Next shp
    Next sld
End Sub


Private Sub ReplaceWordsInTable(ByRef shp As Shape, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    ' give name to table
    Dim tbl As Table
    Set tbl = shp.Table
    ' loops on table rows and columns
    Dim i As Long
    Dim j As Long
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange
    For i = 1 To shp.Table.Rows.Count
        For j = 1 To shp.Table.Columns.Count
            ' Store cell text into a variable
            Set ShpTxt = tbl.Cell(i, j).Shape.TextFrame.TextRange
            If ShpTxt <> "" Then
                ReplaceWordsInTextRange ShpTxt, FindList, ReplaceList
            End If
        Next j
    Next i
End Sub


Private Sub ReplaceWordsInTextFrame(ByRef shp As Shape, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    ' Store shape text into a variable
    Dim ShpTxt As TextRange
    Set ShpTxt = shp.TextFrame.TextRange
    If ShpTxt <> "" Then
        ReplaceWordsInTextRange ShpTxt, FindList, ReplaceList
    End If
End Sub


Private Sub ReplaceWordsInTextRange(ByRef thisRange As TextRange, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    Dim TmpTxt As TextRange
    Dim foundWord As TextRange
    Dim x As Long
    Dim nextCharPosition As Long
    Dim finished As Boolean
    nextCharPosition = 0
    For x = LBound(FindList) To UBound(FindList)
        finished = False
        Do While Not finished
            '--- find the word first, and capture the case of the starting character
            Set foundWord = thisRange.Find(FindWhat:=FindList(x), After:=nextCharPosition, _
            MatchCase:=msoFalse, _
            WholeWords:=msoFalse)
            If Not foundWord Is Nothing Then
                Dim firstCharUpper As Boolean
                firstCharUpper = (foundWord.Characters(0, 1) = UCase(foundWord.Characters(0, 1)))
                Set TmpTxt = thisRange.Replace(FindWhat:=FindList(x), _
                Replacewhat:=ReplaceList(x), _
                MatchCase:=msoFalse, _
                WholeWords:=msoFalse)
                nextCharPosition = TmpTxt.Start + Len(ReplaceList(x))
                If firstCharUpper Then
                    thisRange.Characters(TmpTxt.Start, 1) = UCase(thisRange.Characters(TmpTxt.Start, 1))
                End If
            Else
                finished = True
            End If
        Loop
    Next x
End Sub

[John Wilson]

Not tested properly so make sure you have copies

Create Folders on Desktop

Files
Files2

Place pptx files in Files

Sub Multi_FindReplace()
    ' PURPOSE: Find & Replace a list of text/values throughout  PowerPoint presentation in folder on Desktop named Files
    ' Create a second folder for results called Files2
    Dim pres As Presentation
    Dim suffix As String
    Dim FileName As String
    ' INSERT THE LIST OF MERGE FIELDS HERE
    Dim FindList As Variant
    FindList = Array("word1", "word2", "word3")
    ' INSERT THE LIST OF VARIABLES TO BE INSERTED BY HERE
    Dim ReplaceList As Variant
    ReplaceList = Array("word1.1", "word2.1", "word3.1")
    Dim FolderPath As String
    Dim FolderPath2 As String
    ' Make sure folders exist
    FolderPath = Environ("USERPROFILE") & "\Desktop\Files\"
    FolderPath2 = Environ("USERPROFILE") & "\Desktop\Files2\"
    suffix = "*.pptx"
    FileName = Dir$(FolderPath & suffix)
    While FileName <> ""
        Set pres = Presentations.Open(FolderPath & FileName, False)
        ' Loop through each slide in Presentation
        Dim sld As Slide
        Dim shp As Shape
        For Each sld In pres.Slides
            For Each shp In sld.Shapes
                ' for tables
                If shp.HasTable Then
                    ReplaceWordsInTable shp, FindList, ReplaceList
                End If
                Select Case shp.Type
                    Case Is = msoGroup
                        ReplaceWordsInGroup shp, FindList, ReplaceList
                    Case Else
                        If shp.HasTextFrame Then ReplaceWordsInTextFrame shp, FindList, ReplaceList
                End Select
            Next shp
        Next sld
        pres.SaveAs FolderPath2 & FileName
        pres.Close
        FileName = Dir()
    Wend
End Sub


Private Sub ReplaceWordsInTable(ByRef shp As Shape, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    ' give name to table
    Dim tbl As Table
    Set tbl = shp.Table
    ' loops on table rows and columns
    Dim i As Long
    Dim j As Long
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange
    For i = 1 To shp.Table.Rows.Count
        For j = 1 To shp.Table.Columns.Count
            ' Store cell text into a variable
            Set ShpTxt = tbl.Cell(i, j).Shape.TextFrame.TextRange
            If ShpTxt <> "" Then
                ReplaceWordsInTextRange ShpTxt, FindList, ReplaceList
            End If
        Next j
    Next i
End Sub
 
Private Sub ReplaceWordsInGroup(ByRef shp As Shape, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    Dim L As Long
    For L = 1 To shp.GroupItems.Count
        If shp.GroupItems(L).HasTextFrame Then
            ReplaceWordsInTextFrame shp.GroupItems(L), FindList, ReplaceList
        End If
    Next L
End Sub


Private Sub ReplaceWordsInTextFrame(ByRef shp As Shape, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    ' Store shape text into a variable
    Dim ShpTxt As TextRange
    Set ShpTxt = shp.TextFrame.TextRange
    If ShpTxt <> "" Then
        ReplaceWordsInTextRange ShpTxt, FindList, ReplaceList
    End If
End Sub


Private Sub ReplaceWordsInTextRange(ByRef thisRange As TextRange, _
    ByRef FindList As Variant, ByRef ReplaceList As Variant)
    Dim TmpTxt As TextRange
    Dim foundWord As TextRange
    Dim x As Long
    Dim nextCharPosition As Long
    Dim finished As Boolean
    nextCharPosition = 0
    For x = LBound(FindList) To UBound(FindList)
        finished = False
        Do While Not finished
            '--- find the word first, and capture the case of the starting character
            Set foundWord = thisRange.Find(FindWhat:=FindList(x), After:=nextCharPosition, _
            MatchCase:=msoFalse, _
            WholeWords:=msoFalse)
            If Not foundWord Is Nothing Then
                Dim firstCharUpper As Boolean
                firstCharUpper = (foundWord.Characters(0, 1) = UCase(foundWord.Characters(0, 1)))
                Set TmpTxt = thisRange.Replace(FindWhat:=FindList(x), _
                Replacewhat:=ReplaceList(x), _
                MatchCase:=msoFalse, _
                WholeWords:=msoFalse)
                nextCharPosition = TmpTxt.Start + Len(ReplaceList(x))
                If firstCharUpper Then
                    thisRange.Characters(TmpTxt.Start, 1) = UCase(thisRange.Characters(TmpTxt.Start, 1))
               End If
            Else
                finished = True
            End If
        Loop
    Next x
End Sub