嘿，我碰到过好几个做PPT自动化的朋友踩过这个坑，咱们一步步拆解问题解决掉！

一、先搞定"指定值超出范围"的报错 #

这个报错90%的原因是你的代码没有跳过那些不带文本框的形状——比如PPT里的图片、图表、SmartArt、甚至空的占位符，直接去访问它们的TextFrame.TextRange肯定会触发报错。另外，如果遇到分组形状，里面的子形状也需要单独遍历，不然也会踩坑。

核心解决办法是在访问文本之前加两层关键判断：

• 先用shp.HasTextFrame判断形状是否具备文本框属性
• 再用shp.TextFrame.HasText判断文本框里是否有实际内容

如果是分组形状，还要递归遍历里面的子形状，不然分组内的文本会被完全漏掉。

二、为什么"MONTH XX, 20XX"没被替换？ #

大概率是这几个原因：

1. FindList和ReplaceList里的内容没一一对应，比如拼写错误、大小写不匹配
2. 默认的Find方法是区分大小写的，比如你代码里写的是"Month XX"，但PPT里是全大写的"MONTH XX"就匹配不到
3. 没有设置合适的匹配参数，比如是否要求匹配整个单词、是否忽略格式差异

三、修改后的完整可用代码 #

Sub Multi_FindReplace()
    Dim sld As Slide
    Dim shp As Shape
    Dim subShp As Shape ' 用于处理分组里的子形状
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange
    Dim FindList As Variant
    Dim ReplaceList As Variant
    Dim x As Long
    
    ' 定义要查找和替换的内容，注意要一一对应！
    FindList = Array("MONTH XX, 20XX", "旧短语1", "旧短语2")
    ReplaceList = Array("October 25, 2024", "新短语1", "新短语2")
    
    ' 遍历每一页幻灯片
    For Each sld In ActivePresentation.Slides
        ' 遍历每页里的每个形状
        For Each shp In sld.Shapes
            ' 处理分组形状：递归遍历子形状
            If shp.Type = msoGroup Then
                For Each subShp In shp.GroupItems
                    ProcessShapeText subShp, FindList, ReplaceList
                Next subShp
            Else
                ' 处理普通形状，先判断是否有可访问的文本
                ProcessShapeText shp, FindList, ReplaceList
            End If
        Next shp
    Next sld
    
    MsgBox "批量替换完成！", vbInformation
End Sub

' 单独抽离文本处理逻辑，复用性更强
Sub ProcessShapeText(targetShp As Shape, findArr As Variant, replaceArr As Variant)
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange
    Dim x As Long
    
    ' 核心判断：跳过没有文本框或空文本的形状，彻底避免报错
    If targetShp.HasTextFrame And targetShp.TextFrame.HasText Then
        Set ShpTxt = targetShp.TextFrame.TextRange
        
        ' 遍历每个要替换的条目
        For x = LBound(findArr) To UBound(findArr)
            ' 设置查找参数：不区分大小写，不强制匹配整个单词（可根据需求调整）
            Set TmpTxt = ShpTxt.Find(FindWhat:=findArr(x), MatchCase:=False, MatchWholeWord:=False)
            
            ' 循环替换所有匹配项，避免只替换第一个出现的内容
            Do While Not TmpTxt Is Nothing
                TmpTxt.Text = replaceArr(x)
                ' 定位到下一个匹配项继续替换
                Set TmpTxt = ShpTxt.Find(FindWhat:=findArr(x), After:=TmpTxt.Start + TmpTxt.Length - 1, MatchCase:=False, MatchWholeWord:=False)
            Loop
        Next x
    End If
End Sub

四、关键修改点说明 #

• 新增分组形状处理：专门判断分组类型，递归遍历子形状，不会漏掉分组内的文本内容
• 双重文本存在性检查：HasTextFrame+HasText的组合判断，彻底规避"指定值超出范围"的报错
• 优化查找替换逻辑：
  • 设置MatchCase:=False关闭大小写匹配，解决"MONTH XX"这类大小写不一致的替换问题
  • 用Do While循环替换所有匹配项，而不是只替换第一个出现的内容
  • 把文本处理逻辑抽成独立子过程，代码更清晰，也方便后续扩展功能

五、额外注意事项 #

1. 如果需要替换表格里的文本，还需要添加表格类型判断并遍历单元格文本，需要的话可以随时补充这部分逻辑
2. 运行代码前最好先保存PPT，避免意外崩溃丢失内容
3. 如果仍有个别文本没替换，检查是不是特殊格式（比如艺术字、分栏文本框），这类情况可能需要单独适配处理

内容的提问来源于stack exchange，提问作者MaxF