如何用VBA根据项目名称匹配自动填充邮件收件人(.to)

核心逻辑 #

1. 从当前活动行的Loans工作表F列获取目标项目名称
2. 遍历Distribution工作表，筛选出该项目对应的所有邮箱
3. 将邮箱用分号拼接后，自动填入Outlook邮件的收件人字段

完整VBA代码 #

Sub SendProjectEmail()
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim wsLoans As Worksheet
    Dim wsDist As Worksheet
    Dim projectName As String
    Dim emailList As String
    Dim lastRow As Long
    Dim i As Long
    
    ' 初始化工作表对象
    Set wsLoans = ThisWorkbook.Worksheets("Loans")
    Set wsDist = ThisWorkbook.Worksheets("Distribution")
    
    ' 获取当前活动行的项目名称
    projectName = wsLoans.Range("F" & ActiveCell.Row).Value
    If projectName = "" Then
        MsgBox "当前行项目名称为空，请检查！", vbExclamation
        Exit Sub
    End If
    
    ' 遍历Distribution表收集对应邮箱
    lastRow = wsDist.Cells(wsDist.Rows.Count, "A").End(xlUp).Row ' 假设项目名称在A列，邮箱在B列，可根据实际调整
    emailList = ""
    For i = 2 To lastRow ' 假设第一行是表头
        If wsDist.Range("A" & i).Value = projectName Then
            If emailList <> "" Then emailList = emailList & "; "
            emailList = emailList & wsDist.Range("B" & i).Value
        End If
    Next i
    
    ' 检查是否找到邮箱
    If emailList = "" Then
        MsgBox "未找到该项目对应的邮箱，请检查Distribution表！", vbExclamation
        Exit Sub
    End If
    
    ' 创建Outlook邮件
    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(0)
    
    With outlookMail
        .To = emailList ' 自动填充收件人
        .Subject = "【项目通知】" & projectName ' 示例主题，可自定义
        .Body = "您好，这是关于" & projectName & "的通知邮件。" ' 示例正文，可自定义
        .Display ' 显示邮件，如需直接发送可改为.Send
    End With
    
    ' 释放对象
    Set outlookMail = Nothing
    Set outlookApp = Nothing
    Set wsLoans = Nothing
    Set wsDist = Nothing
End Sub

注意事项 #

• 代码中假设Distribution表的项目名称在A列，邮箱在B列，如果你的表结构不同，需要修改代码中Range("A" & i)和Range("B" & i)的列标识
• 若Distribution表表头不在第一行，需要调整循环起始的i = 2为实际表头下的第一行
• 代码使用Display显示邮件以便预览，如需自动发送，可替换为.Send（注意Outlook的安全设置可能会拦截）

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