VBA循环粘贴Excel多工作表区域为图片到PPT时出现下标越界错误求解

错误原因 #

• 核心报错触发逻辑：当E列没有任何一行取值为Include时，计数变量k全程保持初始值0，执行ReDim Preserve arr(k - 1)时会尝试生成下标为-1的数组，VBA数组下标最小为0，因此直接触发下标越界错误。
• 附带逻辑缺陷：PowerPoint应用初始化、演示文稿创建的逻辑写在循环内部，会导致每处理一行数据就新建一个独立的PPT文件，最终只会保留最后一行数据的导出结果，不符合批量导出需求。

修正后完整代码 #

Sub SelectSheets_Ranges()
    Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
    Dim PowerPointApp As Object, myPresentation As Object, mySlide As Object, myShape As Object
    
    Set sh = ActiveSheet
    lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
    
    ReDim arr(lastR - 1)
    For i = 5 To lastR
        If sh.Range("E" & i).Value = "Include" Then
            arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value
            k = k + 1
        End If
    Next i
    
    ' 新增无匹配数据判断，避免下标越界
    If k = 0 Then
        MsgBox "未找到标记为Include的行，请检查E列配置", vbExclamation
        Exit Sub
    End If
    ReDim Preserve arr(k - 1)
    
    ' PPT初始化逻辑移到循环外，全局只创建一个演示文稿
    On Error Resume Next
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    Err.Clear
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    If Err.Number = 429 Then
        MsgBox "未检测到PowerPoint程序，运行终止", vbCritical
        Exit Sub
    End If
    On Error GoTo 0
    Application.ScreenUpdating = False
    Set myPresentation = PowerPointApp.Presentations.Add
    
    For i = 0 To UBound(arr)
        arrSplit = Split(arr(i), "|")
        Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
        
        ' 每一行数据新建一张幻灯片
        Set mySlide = myPresentation.Slides.Add(i + 1, 11) '11 = ppLayoutTitleOnly
        rng.Copy
        mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        myShape.Left = 66
        myShape.Top = 152
        Application.CutCopyMode = False
    Next
    
    ' 全部处理完成后再显示PPT
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    Application.ScreenUpdating = True
End Sub

额外说明 #

• 运行前请确认C列填写的工作表名称、D列填写的单元格区域格式完全正确，避免后续调用区域时报错
• 如果需要调整导出图片的位置、尺寸，可以自行修改myShape.Left、myShape.Top、myShape.Width、myShape.Height的参数值

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