使用 Excel VBA 从 table 发送电子邮件

Question

我有一个 table 中的电子邮件列表，我想向这些人发送电子邮件。

目前，我的代码只引用了一个存储多封电子邮件的单元格。

emailItem.To = Range("A2").Value
emailItem.CC = Range("B2").Value

如何引用 table 数组，以便在我从通讯组列表中添加或删除某人时，它变成 'dynamic'。

这是我的 table 的样子：

这是我正在使用的代码：

Option Explicit

Sub Send_Email_With_Attachment()    
    Dim emailApplication As Object
    Dim emailItem As Object

    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    'Date Update in Subject Line

    Dim lastSunday As Date
    lastSunday = DateAdd("d", 1 - Weekday(Now), Now)

    'Now build the email.    
    emailItem.To = Range("A2").Value    
    emailItem.CC = Range("B2").Value    

    emailItem.Subject = "Training Report  - " & Format(lastSunday, "dd-MM-yyyy")    
    emailItem.Body = "Dear All" & vbCrLf & vbCrLf & "Please find attached the Weekly  Training report." & vbCrLf & vbCrLf & "Kind Regards,"

    ' Attach any file from computer


    'Send the email
    emailItem.Display 
End Sub

Answer 1

而不是

emailItem.To = Range("A2").Value    
emailItem.CC = Range("B2").Value

使用

Dim EmailTable As ListObject  ' define your email table in the sheet
Set EmailTable = ThisWorkbook.Worksheets("Sheet1").ListObjects("Email2")

emailItem.To = Join(Application.Transpose(EmailTable.ListColumns("To").DataBodyRange.Value2), ";")    
emailItem.CC = Join(Application.Transpose(EmailTable.ListColumns("CC").DataBodyRange.Value2), ";")

请注意，Email2 是您的 table 的名称，Sheet1 需要是工作表的名称。 Transpose 将从我们可以 Join 到由 ;

分隔的字符串中创建一个一维数组

Answer 2

这是我用来生成电子邮件的代码。

代码只有在 'To & CC' 都在同一个 Table 中时才有效。

该代码仅适用于您所在的 ACTIVE Sheet。

该代码还引用了过去的日期，可以很容易地修改。更改这部分代码："("d", 1 - Weekday(Now), Now)" 以满足您的需要。

Option Explicit

Sub Send_Email_With_Attachment()
    Dim OutApp As Object, OutMail As Object
    Dim emailTo As String, emailCC As String
    Dim lastSunday As Date
    Dim c As Range
    
    lastSunday = DateAdd("d", 1 - Weekday(Now), Now)
    
    emailTo = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Email2[To]"))
    emailCC = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Email2[CC]"))
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = emailTo
        .CC = emailCC
        .Subject = "Report  - " & Format(lastSunday, "dd-MM-yyyy")
        .Body = "Dear All" & vbCrLf & vbCrLf & _
        "Please find attached the Weekly report." & vbCrLf & vbCrLf & "Kind Regards,"
        '.Attachments.Add ""
        .Send
    End With
End Sub

使用 Excel VBA 从 table 发送电子邮件

Send Emails using Excel VBA from a table

excel

outlook

vba