如何用VBA基于Excel表格内容通过Outlook向指定人员发送对应数据

前置准备 #

• 新增一个名为「通讯录」的工作表，A列存储姓名，B列存储对应邮箱，数据可从第2行开始录入
• 原有业务数据表保留在Sheet1，公共通用信息存储在A-C列，人员专属数据从D列开始按列排布，第2行对应列填写人员姓名，全表数据范围为A1:D5

完整VBA代码 #

Sub Mail_By_Name_To_Outlook()
    Dim rngPublic As Range, rngPersonal As Range, sendRng As Range
    Dim OutApp As Object, OutMail As Object
    Dim nameCell As Range, addressWs As Worksheet
    Dim sendToMail As String, lastName As String
    
    ' 初始化对象
    Set addressWs = ThisWorkbook.Sheets("通讯录")
    Set rngPublic = Sheets("Sheet1").Range("A1:C5") ' 公共信息区域，可根据实际调整
    Set OutApp = CreateObject("Outlook.Application")
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    ' 遍历第2行所有人员姓名列，示例从D列开始，可调整起始位置
    For Each nameCell In Sheets("Sheet1").Range("D2", Sheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft))
        lastName = nameCell.Value
        If lastName <> "" Then
            ' 匹配对应邮箱
            On Error Resume Next
            sendToMail = Application.WorksheetFunction.VLookup(lastName, addressWs.Range("A:B"), 2, False)
            On Error GoTo 0
            
            If sendToMail <> "" Then
                ' 构造发送区域：公共区域 + 当前人员对应列数据
                Set rngPersonal = Sheets("Sheet1").Range(Cells(1, nameCell.Column), Cells(5, nameCell.Column))
                Set sendRng = Union(rngPublic, rngPersonal).SpecialCells(xlCellTypeVisible)
                
                If Not sendRng Is Nothing Then
                    ' 生成Outlook邮件
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = sendToMail
                        .Subject = lastName & " 专属数据通知" ' 可自定义邮件主题
                        .HTMLBody = RangetoHTML(sendRng)
                        .Display ' 如需直接自动发送，将本行改为 .Send
                    End With
                    Set OutMail = Nothing
                End If
                sendToMail = "" ' 重置邮箱变量避免串用
            End If
        End If
    Next nameCell
    
    ' 恢复Excel设置
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    ' 释放对象
    Set OutApp = Nothing
    Set addressWs = Nothing
    Set rngPublic = Nothing
    Set rngPersonal = Nothing
    Set sendRng = Nothing
End Sub


Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    '复制选区并创建临时工作簿存储数据
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    '将临时工作表发布为htm文件
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    '读取htm文件内容返回
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    '关闭临时工作簿
    TempWB.Close savechanges:=False

    '删除临时htm文件
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

使用注意事项 #

• 运行宏前请确认Outlook处于登录打开状态
• 可根据实际业务的列范围、行范围修改代码中对应区域的参数
• 匹配不到对应邮箱的姓名会自动跳过，不会生成邮件

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