使用VBA将数据透视表粘贴到Outlook邮件时遇运行时错误9

问题场景 #

从工作簿A执行VBA代码，根据动态值生成工作簿B的路径，尝试使用Ron de Bruin的RangetoHTML函数将工作簿B中的数据透视表插入Outlook邮件正文，运行时触发Runtime Error 9: Subscript out of range错误。

错误原因分析 #

该错误通常因引用的对象不存在导致，结合代码排查，可能的触发点包括：

• 直接用文件路径通过Workbooks(source_file)引用未打开的工作簿：Workbooks集合仅包含当前已打开的工作簿，未打开的文件无法通过此方式访问。
• 数据透视表索引6无效：目标工作表中可能不存在第6个数据透视表，或索引对应关系因操作发生变化。
• On Error Resume Next掩盖前置错误：即使工作簿/工作表/透视表不存在，代码仍会继续执行，导致后续调用RangetoHTML(Rng)时因Rng为空触发错误。
• 工作表"Summary"不存在：目标工作簿中可能没有该名称的工作表。

修复方案及代码修正 #

核心修复点 #

1. 先检查并打开目标工作簿：通过自定义函数判断工作簿是否已打开，未打开则自动以只读模式打开（避免锁定文件）。
2. 验证对象存在性：逐一检查工作表、数据透视表是否存在，避免无效引用。
3. 移除错误掩盖语句：删除On Error Resume Next，改用明确的错误检查逻辑定位问题。
4. 处理空范围情况：若透视表无法找到，弹出提示并终止邮件生成流程。

完整修正代码 #

Sub Send_email()
    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    Dim source_file As String
    Dim MAILBOX As String
    Dim CC As String
    Dim Rng As Range
    Dim REASON As String
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim pvtTable As PivotTable
    
    '初始化Outlook对象
    Set OutlookApp = New Outlook.Application
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)
    
    '读取基础数据
    source_file = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 15)
    REASON = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 4)
    MAILBOX = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 13)
    CC = ThisWorkbook.Worksheets("abc").Cells(ActiveCell.Row, 14)
    
    '根据REASON设置目标文件路径
    If REASON = "apple" Then
        source_file = "D:\User\OneDrive\123.xlsx"
    Else
        source_file = "D:\User\OneDrive\456.xlsx"
    End If
    
    '检查并打开目标工作簿
    Set targetWB = GetWorkbook(source_file)
    If targetWB Is Nothing Then
        MsgBox "无法打开目标工作簿：" & source_file, vbCritical
        Exit Sub
    End If
    
    '检查目标工作表是否存在
    On Error Resume Next
    Set targetWS = targetWB.Worksheets("Summary")
    On Error GoTo 0
    If targetWS Is Nothing Then
        MsgBox "目标工作簿中不存在名为Summary的工作表", vbCritical
        '若为代码打开的工作簿，自动关闭
        If Not IsWorkbookOpen(source_file) Then targetWB.Close SaveChanges:=False
        Exit Sub
    End If
    
    '检查数据透视表（建议改用透视表名称，比索引更稳定）
    On Error Resume Next
    '替换为你的透视表名称，示例：Set pvtTable = targetWS.PivotTables("PivotTable1")
    Set pvtTable = targetWS.PivotTables(6)
    On Error GoTo 0
    If pvtTable Is Nothing Then
        MsgBox "Summary工作表中不存在第6个数据透视表", vbCritical
        If Not IsWorkbookOpen(source_file) Then targetWB.Close SaveChanges:=False
        Exit Sub
    End If
    
    '获取透视表范围
    Set Rng = pvtTable.TableRange1
    
    '生成邮件
    With OutlookMail
        .BodyFormat = olFormatHTML
        .To = MAILBOX
        .CC = CC
        .HTMLBody = "<BODY style='font-size:11pt;font-family:Calibri'>" & RangetoHTML(Rng) & .HTMLBody
        .Display '如需直接发送，替换为.Send
    End With
    
    '关闭代码打开的工作簿（按需调整）
    If Not IsWorkbookOpen(source_file) Then
        targetWB.Close SaveChanges:=False
    End If
    
    '释放对象
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    Set targetWB = Nothing
    Set targetWS = Nothing
    Set pvtTable = Nothing
    Set Rng = Nothing
End Sub

'辅助函数：检查工作簿是否已打开
Function IsWorkbookOpen(filePath As String) As Boolean
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(Dir(filePath))
    On Error GoTo 0
    IsWorkbookOpen = Not wb Is Nothing
End Function

'辅助函数：获取已打开或打开指定工作簿
Function GetWorkbook(filePath As String) As Workbook
    Dim wbName As String
    wbName = Dir(filePath)
    
    '检查是否已打开
    If IsWorkbookOpen(filePath) Then
        Set GetWorkbook = Workbooks(wbName)
    Else
        '只读模式打开，避免锁定文件
        On Error Resume Next
        Set GetWorkbook = Workbooks.Open(Filename:=filePath, ReadOnly:=True)
        On Error GoTo 0
    End If
End Function

关键注意事项 #

• 优先使用透视表名称：数据透视表的索引可能因操作变化，改用名称（如PivotTables("PivotTable1")）更稳定。
• 确保RangetoHTML函数存在：需将Ron de Bruin的RangetoHTML函数复制到当前VBA模块中，否则会触发函数未定义错误。
• 文件路径验证：确认source_file对应的路径真实存在，且文件未被其他程序锁定。

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