将电子邮件地址从 Excel 单元格粘贴到 Outlook

Question

我想送生日祝福。我有一个电子邮件地址和日期的列表。

我按日期过滤。如何复制电子邮件地址并发送？

我知道如何复制内容，但 Outlook 不支持该配置进行粘贴。

Sub Envia_Emails()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
         
    Call Filtrar_aniversario
    Worksheets("Query").Activate
    Activated.Cells(2, 2).Copy
    
    With OutlookMail
        .To = ""
        .CC = ""
        .BCC = PasteSpecial
        .Subject = "Feliz Aniversário!"
        .Body = "Feliz aniversário"
        .Display ' para envia o email diretamente defina o código  .Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub


Sub Filtrar_aniversario()
    Application.CutCopyMode = False
    Columns("A:D").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("M4:M5"), Unique:=False
End Sub

Answer 1

您无需将电子邮件地址复制到剪贴板并粘贴。您可以直接将To / CC / BCC 属性设置为带有单个电子邮件地址或";" 分隔的电子邮件地址列表的字符串。

.BCC = Range("M4:M5").Text

更新以下脚本对我来说很好用：

Sub Envia_Emails()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    'Call Filtrar_aniversario
    With OutlookMail
        .To = ""
        .CC = ""
        .BCC = Application.Range("A1:A1").Text
        .Subject = "Feliz Aniversário!"
        .Body = "Feliz aniversário"
        .Display ' para envia o email diretamente defina o código
        '.Send
    End With
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

更新 2：想不到：

 for each r in Application.Range("B2:B6")
   set recip = OutlookMail.Recipients.Add(r.Text)
   recip.Type = 3 'olBCC
 next