如何实现B列（第6行起）值匹配B4时向对应E列邮箱发邮件？

原代码存在三个核心问题导致无法正确筛选邮箱：

1. 循环起始行错误：需求是从第6行开始匹配B列值，但代码从第2行开始遍历
2. 重复创建Outlook实例：每次符合条件都新建Outlook对象，既效率低下又可能引发异常
3. 邮箱范围错误：Range("E6:E" & lRow)会提取从E6到当前遍历行的所有邮箱，而非仅当前符合条件行的邮箱，导致每次匹配时都累加之前的邮箱

以下是修正后的代码：

Sub ClubEmails()
    Dim xOutlook As Object
    Dim xMailItem As Object
    Dim lLastRow As Long
    Dim lRow As Long
    Dim strbody As String
    Dim xEmailAddr As String
    
    strbody = "Text goes here"
    xEmailAddr = "" ' 初始化邮箱字符串
    
    ' 获取B列最后一行行号
    lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    
    ' 遍历第6行到最后一行，匹配B列值
    For lRow = 6 To lLastRow
        If Cells(lRow, 2).Value = Range("B4").Value Then
            ' 追加符合条件的邮箱，用逗号分隔
            If xEmailAddr <> "" Then xEmailAddr = xEmailAddr & ","
            xEmailAddr = xEmailAddr & Cells(lRow, 5).Value ' E列是第5列
        End If
    Next lRow
    
    ' 仅当收集到邮箱时才创建邮件
    If xEmailAddr <> "" Then
        Set xOutlook = CreateObject("Outlook.Application")
        Set xMailItem = xOutlook.CreateItem(0)
        
        On Error Resume Next
        With xMailItem
            .To = ""
            .CC = ""
            .BCC = xEmailAddr
            .Subject = "Test Email"
            .HTMLBody = strbody
            .Display ' 若要直接发送，替换为.Send
        End With
        On Error GoTo 0 ' 恢复错误捕获
        
        MsgBox "E-mail successfully created", vbInformation
    Else
        MsgBox "No matching emails found", vbExclamation
    End If
    
    ' 释放对象
    Set xMailItem = Nothing
    Set xOutlook = Nothing
End Sub

修正关键点说明 #

• 调整循环起始为第6行，严格匹配需求的表格起始行
• 提前初始化邮箱字符串，循环中仅收集符合条件的单个邮箱，避免范围错误
• 仅创建一次Outlook实例，提升效率并减少异常风险
• 增加判断逻辑，确保只有在收集到有效邮箱时才创建邮件，避免空邮件的情况

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