使用 VBA 查找和替换 PowerPoint 演示文稿中的单词列表，包括表格

Question

我已经尝试解决这个问题几天了，尽管谷歌搜索了很多，但我还是很卡住，所以非常感谢任何指点:)

所以我试图用另一个替换单词列表（我的文件是用于多个项目的模板）。它在文本框中工作得很好，但不适用于表格，所以我尝试将文本框代码调整为表格。下面的代码运行时没有给我一条错误消息，但仍然没有编辑我的表...

Sub Multi_FindReplace()

'PURPOSE: Find & Replace a list of text/values throughout entire PowerPoint presentation

Dim sld As Slide
Dim shp As Shape
Dim ShpTxt As TextRange
Dim TmpTxt As TextRange
Dim FindList As Variant
Dim ReplaceList As Variant
Dim x As Long
Dim i As Long
Dim j As Long
Dim tbl As Table


' INSERT THE LIST OF MERGE FIELDS HERE
FindList = Array("word1", "word2", "word3")

' INSERT THE LIST OF VARIABLES TO BE INSERTED BY HERE  
ReplaceList = Array("word1.1", "word2.1", "word3.1")


'Loop through each slide in Presentation
  For Each sld In ActivePresentation.Slides

    For Each shp In sld.Shapes

        '''''for tables
        If shp.HasTable Then

                'give name to table
                Set tbl = shp.Table

                'loops on table rows and columns
                For i = 1 To shp.Table.Rows.Count
                    For j = 1 To shp.Table.Columns.Count

                        'Store cell text into a variable
                        ShpTxt = tbl.Cell(i, j).Shape.TextFrame.TextRange


                          'Ensure There is Text To Search Through
                          If ShpTxt <> "" Then
                             For x = LBound(FindList) To UBound(FindList)

                             'Store text into a variable
                            'Set ShpTxt = shp.TextFrame.TextRange

                             'Find First Instance of "Find" word (if exists)
                             Set TmpTxt = ShpTxt.Replace( _
                              FindWhat:=FindList(x), _
                              Replacewhat:=ReplaceList(x), _
                              WholeWords:=False)

                             'Find Any Additional instances of "Find" word (if exists)
                              Do While Not TmpTxt Is Nothing
                                Set ShpTxt = ShpTxt.Characters(TmpTxt.Start + TmpTxt.Length, ShpTxt.Length)
                                Set TmpTxt = ShpTxt.Replace( _
                                  FindWhat:=FindList(x), _
                                  Replacewhat:=ReplaceList(x), _
                                  WholeWords:=False)
                              Loop
                             Next x
                          End If


                     Next j
                Next i
        Else


        ''''for all shapes excluding tables
        If shp.HasTextFrame Then

           'Store shape text into a variable
           Set ShpTxt = shp.TextFrame.TextRange

            'Ensure There is Text To Search Through
             If ShpTxt <> "" Then
                For x = LBound(FindList) To UBound(FindList)

                'Store text into a variable
                'Set ShpTxt = shp.TextFrame.TextRange

                'Find First Instance of "Find" word (if exists)
                Set TmpTxt = ShpTxt.Replace( _
                  FindWhat:=FindList(x), _
                  Replacewhat:=ReplaceList(x), _
                  WholeWords:=False)

                'Find Any Additional instances of "Find" word (if exists)
                Do While Not TmpTxt Is Nothing
                  Set ShpTxt = ShpTxt.Characters(TmpTxt.Start + TmpTxt.Length, ShpTxt.Length)
                  Set TmpTxt = ShpTxt.Replace( _
                    FindWhat:=FindList(x), _
                    Replacewhat:=ReplaceList(x), _
                    WholeWords:=False)
                Loop
               Next x
            End If

        End If

        End If

    Next shp

Next sld


End Sub

Answer 1

我对你的代码做了一些重构，以提高它的可读性和可维护性。

由于您将所有内容都包含在一个 Sub 中，因此很难理解其中的所有内容，尤其是当 If 语句的不同部分中有大量代码时。所以你的主要例程最终看起来像这样：

Option Explicit

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

现在更容易理解，而且很清楚您处理 TextFrames 的方式与处理 Tables 的方式不同。此外，该组织将您的顶级例程简化为基本设置和初始化，然后是高级逻辑流程。

接下来看两个“ReplaceWords”子例程：

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

您会注意到循环被简化为单个 Replace 语句（因此您不必执行 find-the-first-word-then-try-again 逻辑）。此外，我在测试中发现，如果找到了 FindList 上的某个单词并以大写字母开头，则替换操作会将其保留为小写单词。所以我实现了一个Find 语句，这样我们就可以捕获第一个字母的大小写，并在替换后重新设置第一个字母。

这里的整个模块是一个单独的块：

Option Explicit

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