VBA按邮箱分组生成工作簿发邮件时触发Runtime 424错误求助

问题定位 #

你的代码触发424错误的核心原因是工作表名称不匹配，同时存在几个次要问题放大了错误影响：

• 工作表引用不一致：创建新工作簿时将默认工作表命名为"GI Data"，但复制行时却尝试引用不存在的"Data"工作表，直接导致对象找不到错误。
• 变量未显式声明：TempFilePath等变量未声明，不符合VBA最佳实践，可能引发变量类型冲突。
• 首次复制目标行错误：新工作簿工作表为空时，End(xlUp).Row + 1会定位到第2行，导致首条数据被放到第2行，首行留空。
• 错误处理不当：On Error Resume Next掩盖了空邮箱值等潜在问题，无法提前排查无效数据。

修正后的完整代码 #

Option Explicit ' 强制变量声明，提前发现未声明变量问题

Sub Button1_Click()
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim emailColumn As Integer
    Dim emailDict As Object
    Dim email As Variant
    Dim newWb As Workbook
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim i As Integer
    Dim TempFilePath As String ' 显式声明变量
    Dim TempFileName As String
    Dim TempFilePathFile As String
    Dim targetWs As Worksheet ' 新增变量简化引用
    Dim targetRow As Long

    ' 设置邮箱列（第7列）
    emailColumn = 7

    ' 创建字典存储邮箱对应的工作簿
    Set emailDict = CreateObject("Scripting.Dictionary")
    ' 设置源工作表
    Set ws = ThisWorkbook.Sheets("Monthly Info")
    
    ' 获取邮箱列最后一行
    lastrow = ws.Cells(ws.Rows.Count, emailColumn).End(xlUp).Row

    ' 按邮箱分组数据
    For i = 2 To lastrow
        email = Trim(ws.Cells(i, emailColumn).Value) ' 去除邮箱前后空格
        ' 跳过空邮箱行
        If email <> "" Then
            If Not emailDict.Exists(email) Then
                ' 创建新工作簿并命名工作表
                Set newWb = Workbooks.Add
                Set targetWs = newWb.Sheets(1)
                targetWs.Name = "GI Data"
                ' 将源表表头复制到新工作簿
                ws.Rows(1).Copy Destination:=targetWs.Range("A1")
                emailDict(email) = newWb
            End If
            ' 获取目标工作表
            Set targetWs = emailDict(email).Sheets("GI Data")
            ' 计算目标行：如果表头存在，找到最后一行+1
            targetRow = targetWs.Cells(targetWs.Rows.Count, 1).End(xlUp).Row + 1
            ' 复制当前行到目标位置
            ws.Rows(i).Copy Destination:=targetWs.Range("A" & targetRow)
        End If
    Next i

    ' 初始化Outlook应用
    Set OutlookApp = CreateObject("Outlook.Application")

    ' 遍历字典发送邮件
    For Each email In emailDict.Keys
        Set newWb = emailDict(email)
        Set targetWs = newWb.Sheets("GI Data")
        
        ' 设置临时文件路径
        TempFilePath = Environ$("temp") & "\"
        TempFileName = "Data for " & Replace(email, "@", "_") & ".xlsx" ' 替换@避免路径问题
        TempFilePathFile = TempFilePath & TempFileName
        
        ' 保存临时工作簿
        newWb.SaveAs TempFilePathFile, FileFormat:=xlOpenXMLWorkbook

        ' 创建并发送邮件
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = email
            .Subject = "Monthly Payment Report"
            .Body = "Hello! Attached is your monthly payment report."
            .Attachments.Add TempFilePathFile
            .Send ' 如果需要测试，可改为.Display先预览
        End With

        ' 关闭并删除临时文件
        newWb.Close SaveChanges:=False
        Kill TempFilePathFile
    Next email

    ' 清理对象
    Set emailDict = Nothing
    Set OutlookApp = Nothing
    Set OutlookMail = Nothing
    Set ws = Nothing
    Set newWb = Nothing
    Set targetWs = Nothing
End Sub

关键修改说明 #

• 添加Option Explicit：强制变量声明，提前发现未声明变量的问题。
• 统一工作表名称：将复制目标工作表统一为"GI Data"，避免对象引用错误。
• 添加表头复制：确保每个新工作簿包含源表的表头信息，数据更完整。
• 处理空邮箱：跳过空邮箱的行，避免创建无效的空键字典项。
• 简化对象引用：新增targetWs变量，避免重复冗长的对象链式调用，提升代码可读性。
• 替换邮箱特殊字符：保存文件时替换@为_，避免因特殊字符导致的文件保存失败。

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