如何循环遍历Range行优化VBA邮件发送代码？

问题需求 #

需要优化VBA邮件发送代码，无需每次创建新模块，实现按行循环读取数据发送邮件：依次使用第1行（I1、H1、M1）、第2行（I2、H2、M2）等行的单元格数据，完成批量邮件发送。尝试过用ActiveCell和Range A1:A20实现循环，以下是原代码及尝试的循环代码，询问该方案是否可行。

原代码 #

Function Email()
Dim iMsg, iConf, Flds

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

With Flds
    schema = "http://schemas.microsoft.com/cdo/configuration/"
    .Item(schema & "sendusing") = 2
    .Item(schema & "smtpserver") = "XXXXXXX"
    '配置邮件发送端口（出站端口）
    .Item(schema & "smtpserverport") = XXXX
    .Item(schema & "smtpauthenticate") = 1
    .Item(schema & "sendusername") = "XXXXXXXXXXXX"
    .Item(schema & "sendpassword") = "XXXXXXXXXXXXXX"
    .Item(schema & "smtpusessl") = True
    .Update
End With

With iMsg
    .To = Sheets("Data").Range("I5").Value
    .From = "xxxxxxxxxxxxx"
    .CC = Sheets("Dados").Range("H5").Value '注意此处工作表名是Dados，其他地方是Data，可能拼写错误
    .Subject = Sheets("Data").Range("K5").Value
    .Sender = "XXXXXXXXXXXXXXXXXXXX"
    .HTMLBody = Sheets("Data").Range("M5").Value '原代码此处多了一个`符号，需删除
    Set .Configuration = iConf
    .Send '原代码缺少发送邮件的语句
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Function

Sub disparar()
    Email
    MsgBox "Success!", vbOKOnly, "E-mail Sent"
End Sub

尝试的循环代码 #

Function Email()
Dim iMsg, iConf, Flds
Dim xrow As Integer

xrow = 1

Do Until IsEmpty(Range("A" & xrow)) '未指定工作表，可能读取错误工作表的A列
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration") '循环内重复创建配置对象，效率低
    Set Flds = iConf.Fields

    With Flds
        schema = "http://schemas.microsoft.com/cdo/configuration/"
        .Item(schema & "sendusing") = 2
        .Item(schema & "smtpserver") = "XXXXXXX"
        .Item(schema & "smtpserverport") = XXXX
        .Item(schema & "smtpauthenticate") = 1
        .Item(schema & "sendusername") = "XXXXXXXXXXXX"
        .Item(schema & "sendpassword") = "XXXXXXXXXXXXXX"
        .Item(schema & "smtpusessl") = True
        .Update
    End With

    With iMsg
       .To = Sheets("Data").Range("I" & xrow).Value
       .From = "xxxxxxxxxxxxx"
       .CC = Sheets("Data").Range("H" & xrow).Value
       .Subject = Sheets("Data").Range("K" & xrow).Value
       .Sender = "XXXXXXXXXXXXXXXXXXXX"
       .HTMLBody = Sheets("Data").Range("M" & xrow).Value '原代码此处多了一个`符号，需删除
        Set .Configuration = iConf
        .Send '缺少发送邮件的语句
    End With

    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
Loop
End Function

Sub send()
    Email
    MsgBox "Success!", vbOKOnly, "E-mail Sent"
Loop '此处多余Loop语句，语法错误
End Sub

方案可行性分析及优化 #

你的循环思路是可行的，但尝试的代码存在多处语法错误和效率问题，导致无法正常运行：

1. 语法错误：send子程序末尾多余Loop；原代码中HTMLBody行多了一个符号；缺少邮件发送的.Send`语句。
2. 效率问题：循环内重复创建CDO配置对象（iConf），完全可以只创建一次配置，循环复用。
3. 潜在bug：IsEmpty(Range("A" & xrow))未指定工作表，若当前激活工作表不是"Data"，会读取错误数据；原代码中工作表名存在Dados和Data的拼写差异，需统一。

优化后的代码 #

将CDO配置提取到循环外，只初始化一次，循环内仅处理邮件内容和发送，同时修复所有语法错误：

Sub BatchSendEmails()
    Dim iMsg As Object, iConf As Object, Flds As Object
    Dim xrow As Integer
    Dim ws As Worksheet
    
    '指定数据所在工作表，避免激活工作表影响
    Set ws = ThisWorkbook.Sheets("Data")
    xrow = 1
    
    '初始化CDO配置，仅执行一次
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
    With Flds
        Dim schema As String
        schema = "http://schemas.microsoft.com/cdo/configuration/"
        .Item(schema & "sendusing") = 2
        .Item(schema & "smtpserver") = "XXXXXXX"
        .Item(schema & "smtpserverport") = XXXX
        .Item(schema & "smtpauthenticate") = 1
        .Item(schema & "sendusername") = "XXXXXXXXXXXX"
        .Item(schema & "sendpassword") = "XXXXXXXXXXXXXX"
        .Item(schema & "smtpusessl") = True
        .Update
    End With
    
    '循环读取数据发送邮件
    Do Until IsEmpty(ws.Range("A" & xrow))
        '跳过收件人为空的行
        If ws.Range("I" & xrow).Value <> "" Then
            Set iMsg = CreateObject("CDO.Message")
            With iMsg
                .To = ws.Range("I" & xrow).Value
                .From = "xxxxxxxxxxxxx"
                .CC = ws.Range("H" & xrow).Value
                .Subject = ws.Range("K" & xrow).Value
                .Sender = "XXXXXXXXXXXXXXXXXXXX"
                .HTMLBody = ws.Range("M" & xrow).Value
                Set .Configuration = iConf
                .Send '执行邮件发送
            End With
            Set iMsg = Nothing
        End If
        xrow = xrow + 1
    Loop
    
    '释放对象
    Set Flds = Nothing
    Set iConf = Nothing
    MsgBox "批量邮件发送完成！", vbOKOnly, "操作成功"
End Sub

优化点说明 #

• 无需创建多个模块，单个子程序即可完成批量发送。
• CDO配置仅初始化一次，提升运行效率。
• 指定工作表对象，避免因激活工作表变化导致的错误。
• 增加收件人非空判断，跳过无效数据行。
• 修复所有语法错误，确保代码可正常运行。

内容的提问来源于stack exchange，提问作者James O'connor