PPT中批量替换内容

teleman

不知PPT中是否可以实现批量替换内容，或通过其他方式也可，以下为举例
例:想把PPT文档中所有的"A"替换为“B”，“C”替换为“D"，"E"替换为“F”....，大概共1000项，请问是否有方法可以实现
感谢

rwan_hello

可以的，利用遍历所有幻灯片可以实现。

011070110

给个实例吧
Sub 批量替换字符()
Dim sld As Slide, shp As Shape
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    Set trng = shp.TextFrame.TextRange
                    For i = 1 To trng.Characters.Count
                         With trng.Characters(i)
                           If .Text = "A" Then
                              .Text = "B"
                              .Font.Color = Choose(Int(Rnd * 3 + 1), vbBlue, vbGreen, vbRed, vbYellow)
                              .Font.Bold = True
                           End If
                           If .Text = "C" Then
                              .Text = "D"
                              .Font.Color = Choose(Int(Rnd * 3 + 1), vbBlue, vbGreen, vbRed, vbYellow)
                           End If
                           If .Text = "E" Then
                              .Text = "F"
                              .Font.Color = Choose(Int(Rnd * 3 + 1), vbBlue, vbGreen, vbRed, vbYellow)
                              .Font.Bold = True
                           End If
                         End With
                    Next
                 End If
             End If
         Next
     Next
End Sub

实例.zip (73.26 KB, 下载次数: 12)

2017-2-16 19:03 上传

点击文件名下载附件

wendy.dai

若是上千页，上述代码自然不是好的解决方案，下面的代码，是优化的代码，效率高一些，继续提供下载。
Sub 批量替换字符()
arr = Array("A", "C", "E", "G", "I", "K", "M") '被替换的字符
brr = Array("B", "D", "F", "H", "J", "L", "N") '替换后的字符
x = LBound(arr)
Z = UBound(arr)
Dim sld As Slide, shp As Shape
    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    Set trng = shp.TextFrame.TextRange
                    For i = x To Z
                       trng.Replace FindWhat:=arr(i), Replacewhat:=brr(i), WholeWords:=True
                    Next
                 End If
             End If
         Next
     Next
End Sub

实例2.zip (74.45 KB, 下载次数: 32)

2017-2-16 19:03 上传

点击文件名下载附件

trott90

厉害，学习了！