Consulting

Results 1 to 2 of 2

Thread: Batch find and replace texts in powerpoint ?

  1. #1
    VBAX Newbie
    Joined
    Nov 2020
    Posts
    1
    Location

    Batch find and replace texts in powerpoint ?

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,963
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •