根据 Excel 表格中的内容将表格从 Excel 发送给 Outlook 中的特定人员

Posted 2023-03-27

【中文标题】根据 Excel 表格中的内容将表格从 Excel 发送给 Outlook 中的特定人员

【英文标题】：Send table from Excel to specific people in Outlook based on content in Excel table

【发布时间】：2022-01-12 15:53:41

【问题描述】：

要求：要从 Excel 中提取信息，请根据列中的名称将信息发送到 Outlook 上的相应电子邮件地址。

例如：如果单元格包含“Mary”，则复制整个表格并发送到 Mary 的电子邮件地址。

我将姓名列表及其各自的电子邮件地址保存在单独的表格中。

这是信息，假设范围是 A1:D5

这是电子邮件地址列表，在单独的表格中

更新：长数据

玛丽想要的输出

思路：在数据表中， i) 我想查找每个名称的第 2 行（名称）， ii) 将该人的信息复制到 Outlook 中。

例如： 对于 Mary，请复制 A1：C5 并发送到 Mary 的电子邮件地址。 对于 Tom，复制标题 (A1:A5) 和 Tom 的数据 (D1:D5)，不包括 Mary 的数据，然后发送到 Tom 的电子邮件地址。

我被困在如何进行循环搜索上。我只有基本的宏来提取数据并发送到 Outlook，没有名称参考：

Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("Sheet1").Range("A1:D5").SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected. " & _
           vbNewLine & "Please correct and try again.", vbOKOnly
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


With OutMail
    .To = "[e-mail]"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .htmlBody = RangetoHTML(rng)
    .Display
End With
On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

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

【问题讨论】：

如果您拥有所有这些自定义案例，那么您需要创建一个包含所有这些选项的 IF/ELSE 或 Select Case 语句树。 If Name = "Mary" Then X: ElseIf Name = "Tom" Then Y

您似乎只需要根据您的业务规则在代码中添加一些条件语句。所以，我建议学习 VBA 并在代码中实现这些东西。

【参考方案1】：

您可以遍历列（从右到左）并隐藏不需要的列。

update1 - 限制为 5 行

update2 - 如果没有可见的列，则不发送

update3 - 添加了重新格式化

Option Explicit

Sub Mail_Selection_Range_Outlook_Body()

    Dim wb As Workbook
    Dim wsUser As Worksheet, wsTable As Worksheet, wsEmail As Worksheet
    Dim rng As Range, n As Long
    Dim lastcol As Long, lastrow As Long, i As Long, c As Long
    Dim sName As String, sAddr As String
          
    Set wb = ThisWorkbook
    Set wsTable = wb.Sheets("Sheet1")
    Set wsEmail = wb.Sheets("Email")
    
    With wsTable
        lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
    End With
      
    Dim OutApp As Object, OutMail As Object, bSend As Boolean
    Set OutApp = CreateObject("Outlook.Application")

    ' for each user
    Set wsUser = wb.Sheets("Sheet2")
    With wsUser
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lastrow
            sName = .Cells(i, "A")
            sAddr = .Cells(i, "B")
            bSend = False
            
            ' hide columns for not name
            wsTable.Columns.Hidden = False
            For c = lastcol To 2 Step -1
                If wsTable.Cells(2, c).Value2 <> sName _
                    Or wsTable.Cells(3, c).Value2 = "Beef" Then
                    wsTable.Columns(c).Hidden = True
                Else
                    bSend = True
                End If
            Next
            
            ' send email
            If bSend Then
            
                ' visible
                ' copy to email sheet
                Set rng = wsTable.UsedRange.Rows("1:5").SpecialCells(xlCellTypeVisible)
                wsEmail.Cells.Clear
                rng.Copy wsEmail.Range("A1")
                Set rng = Reformat(wsEmail)
                
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .to = sAddr
                    .CC = ""
                    .BCC = ""
                    .Subject = "This is the Subject line"
                    .HTMLBody = RangetoHTML(rng)
                    .Display
                End With
                wsEmail.Cells.Clear
                n = n + 1
            End If            
        Next
    End With

    wsTable.Columns.Hidden = False
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    MsgBox n & " emails sent", vbInformation
End Sub

Function Reformat(ws) As Range

    Const MAX = 4
    Dim lastrow As Long, lastcol As Long
    Dim r As Long, c As Long
 
    With ws
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      
        r = lastrow + 2
        c = MAX + 2
        Do While c <= lastcol
            .Cells(1, 1).Resize(lastrow).Copy .Cells(r, 1)
            .Cells(1, c).Resize(lastrow, MAX).Copy .Cells(r, 2)
            c = c + MAX
            r = r + lastrow + 2
        Loop
        
        .Columns(MAX + 2).Resize(, lastcol).Delete
    End With
    Set Reformat = ws.UsedRange
    
End Function

【讨论】：

感谢 CDP！这对我正在寻找的东西很好！如果我想添加另一个条件，假设我想排除第 3 行中包含“牛肉”的列，我应该如何修改这个？另外，如果我只想复制前 5 行而不是所有行呢？希望这不会给您带来麻烦，并非常感谢您的帮助，先生。

@MingXi OK 看更新

嗨 CDP！我似乎遇到了一个问题，它发送给“Sheet2”中的每个人 - 我在那里有一个人员列表和他们的电子邮件，并且代码会自动将其发送给列表中的每个人（空电子邮件），即使他们的名字不在工作表中1. 谢谢先生的帮助

@MingXi 你的例子只显示了两张纸上的人，请参阅更新，

干杯先生！祝你节日快乐。感谢您的更新，这对我来说非常有用。然而，当我继续添加我的数据时，我意识到这些列越来越长，这使得在 Outlook 中很难完全查看。因此，您是否知道复制上述代码的方法，使其仅捕获“Mary”的第一列 + 前四个实例，如果“Mary”中有更多数据，则跳过一行并在下面显示它们。对其他用户重复相同的操作（如果适用），然后按上述方式发送电子邮件。我知道需要删除范围限制 t00 查看图片