问查找并替换PowerPoint演示文稿中的单词列表，包括表格
EN

Stack Overflow用户

提问于 2018-10-16 14:08:45

回答 1查看 621关注 0票数 2

这几天我一直在尝试解决这个问题，尽管我在谷歌上搜索了很多次，但我还是被困住了，所以我真的很感激任何人的建议:)

因此，我正在尝试用另一个单词列表替换单词列表(我的文件是用于多个项目的模板)。它在textboxes中运行良好，但不适用于表格，因此我尝试将textboxes代码调整为表格。下面的代码运行时没有给我一条错误消息，但仍然不编辑我的表...

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

powerpoint

arrays

vba

replace

回答 1

Stack Overflow用户

发布于 2018-10-16 19:40:01

为了提高代码的可读性和可维护性，我对您的代码进行了一些重构。

由于您将所有内容都包含在一个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

这些subs中的每一个都有专门用于拆分文本框架或表格的逻辑。但请注意，在您的原始代码中，替换代码实际上是相同的。所以现在这是一个单独的例程。

通过分离实际的替换操作，它是“功能隔离的”，现在使你的代码保持一致，更容易维护。你在一个地方做了一件事。如果有问题，就在那里修复它。

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语句(因此您不必执行查找第一个单词然后重试的逻辑)。此外，我在测试中发现，如果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