基于工作表名称发送邮件的Excel VBA代码报错求助

错误原因分析 #

你代码里报错的那行.To = xWs.Sheets(i).Name & "@gmail.com"有两个致命问题：

• xWs本身就是单个工作表对象，不是工作簿，根本没有Sheets集合属性，直接用xWs.Name就能拿到当前要发送的工作表名称。
• 变量i从头到尾没定义、没赋值，属于无意义的无效引用。

修正后的完整代码 #

Sub Mail_Every_Worksheet()
    Dim xWs As Worksheet
    Dim xWb As Workbook
    Dim xFileExt As String
    Dim xFileFormatNum As Long
    Dim xTempFilePath As String
    Dim xFileName As String
    Dim xOlApp As Object
    Dim xMailObj As Object
    Dim subj As String
    Dim body As String
    Dim CurrDate As String
    
    ' 获取邮件主题和正文
    subj = InputBox("请输入邮件主题")
    body = InputBox("请输入邮件正文")
    CurrDate = Format(Date, "MM-DD-YY")
    
    ' 关闭屏幕刷新和事件，提升运行速度
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    xTempFilePath = Environ$("temp") & "\"
    
    ' 根据Excel版本设置文件格式
    If Val(Application.Version) < 12 Then
        xFileExt = ".xls": xFileFormatNum = -4143
    Else
        ' 若原文件是无宏xlsx，可改为xFileExt = ".xlsx": xFileFormatNum = 51
        xFileExt = ".xlsm": xFileFormatNum = 52
    End If
    
    ' 创建Outlook对象，仅在此处捕获启动错误
    On Error Resume Next
    Set xOlApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    If xOlApp Is Nothing Then
        MsgBox "无法启动Outlook，请检查是否安装", vbCritical
        GoTo Cleanup
    End If
    
    ' 遍历每个工作表
    For Each xWs In ThisWorkbook.Worksheets
        ' 跳过名为Sheet1的工作表（可按需修改）
        If xWs.Name <> "Sheet1" Then
            xWs.Copy ' 将当前工作表复制为新工作簿
            Set xWb = ActiveWorkbook
            xFileName = xWs.Name & " " & CurrDate
            
            Set xMailObj = xOlApp.CreateItem(0) ' 创建新邮件
            
            With xWb
                ' 保存临时文件
                .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
                
                With xMailObj
                    ' 修正：直接用工作表名称生成收件人邮箱
                    .To = xWs.Name & "@gmail.com"
                    .CC = ""
                    .BCC = ""
                    .Subject = subj
                    .Body = body ' 统一使用Outlook标准大写属性名
                    .Attachments.Add xWb.FullName
                    .Display ' 若要自动发送，替换为.Send（需注意Outlook安全设置）
                End With
                
                .Close SaveChanges:=False ' 关闭临时工作簿，不保存
            End With
            
            ' 清理对象和临时文件
            Set xMailObj = Nothing
            Kill xTempFilePath & xFileName & xFileExt
        End If
    Next xWs
    
Cleanup:
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Set xOlApp = Nothing
    MsgBox "邮件批量处理完成", vbInformation
End Sub

关键修改说明 #

1. 修正收件人赋值：替换错误的收件人代码，直接用当前遍历的工作表名称生成邮箱地址。
2. 优化错误处理：仅在创建Outlook对象时临时启用错误捕获，避免隐藏其他潜在问题；增加Outlook启动失败的提示。
3. 规范属性名称：把原代码里的小写.body改成Outlook标准的.Body属性，避免兼容问题。
4. 完善流程闭环：添加Cleanup标签，确保无论是否出错都能恢复Excel的屏幕刷新和事件设置；增加处理完成的提示。

额外注意事项 #

• 如果你的Excel文件是无宏的.xlsx格式，请修改文件格式配置为xFileExt = ".xlsx": xFileFormatNum = 51。
• 若要自动发送邮件而非仅显示，将.Display改为.Send，但需提前配置Outlook信任中心以允许自动发送。

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