excel - 通过 Outlook 电子邮件通过 VBA 宏在同一工作簿中发送多个工作表？

Question

我想将位于一个工作簿中的多个工作表（例如，Sheet71、Sheet76、Sheet60 和 Sheet77）复制到另一个工作簿中，以便通过电子邮件发送给我在工作表 71 上的电子邮件密钥表中列出的收件人。

这些电子邮件将发送给个人，以概述他们的奖金。

因此，收件人只能收到他们自己的或他们负责的人，这一点至关重要。

我已经弄清楚如何将一张工作表发送给一个收件人，但无法弄清楚如何在不使用工作表上的名称（皮尔斯组矩阵、随机矩阵、赌博矩阵和里德矩阵）与 Sheet71 的情况下使用多个工作表来完成此操作， VBA 中的 Sheet76、Sheet60 和 Sheet77。

我需要能够在宏中引用工作表编号而不是名称，因为确实会发生周转。

下面是我编写的代码，用于通过一个工作表向我的电子邮件密钥表 (Sheet81) 中的一个人发送电子邮件，但它只发送表 71。

我已经尝试了 Array 关键字和多个其他关键字，但似乎无法使其正常工作。

我需要参考工作表编号而不是工作表名称，因为替换人员时名称会更改。

我更愿意像下面的代码那样制作一个副本，但是如果可以的话，我愿意尝试一个 Select 命令。

Sub Mail()

Dim OutlookApp As Object
Dim Mess As Object, Recip
Recip = Sheet81.[C35].Value
newDate = MonthName(Month(DateAdd("m", -1, Date)), False)

 ' Make a copy of the active worksheet
' and save it to a temporary file
Sheet71.Copy
Set WB = ActiveWorkbook

Filename = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\" & Filename
On Error GoTo 0
WB.SaveAs Filename:="C:\" & Filename

Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = (newDate + " Matrix")
.Body = ("Attached is your " + newDate + " bonus matrix.  Thanks! Neil")
.to = Recip
.Attachments.Add WB.FullName
.Display
.Send
End With
ActiveWorkbook.Close

Set OutlookApp = Nothing
Set Mess = Nothing
End Sub

标签： excelvbaoutlook

Answer 1

在这种方法中，我选择创建一个名为sendMultMails. 这将创建您选择添加的工作表集合。由于您不想使用工作表名称作为参考，因此我使用了工作表的CodeName。

因此，将您的工作表添加到集合并循环该集合。在循环中，您将调用其他例程Mail，将工作表作为参数传递。

Sub sendMultMails()

    Dim wsColl As New Collection, ws As Worksheet

    Rem: Add your worksheets to the collection via the worksheet's CodeName
    With wsColl
        .Add Sheet71
        .Add Sheet76
        .Add Sheet60
        .Add Sheet77
    End With

    Rem: loop through each collection item, calling the Mail Routine
    For Each ws In wsColl
        Mail ws
    Next

End Sub

Rem: Added an argument for you to pass the ws obj to this routine
Sub Mail(ws As Worksheet)

    Dim OutlookApp As Object
    Dim Mess As Object, Recip
    Recip = ws.Range("C35").Value
    newDate = MonthName(Month(DateAdd("m", -1, Date)), False)

     ' Make a copy of the active worksheet
    ' and save it to a temporary file
    ws.Copy
    Set WB = ActiveWorkbook

    Filename = WB.Worksheets(1).Name
    On Error Resume Next
    Kill "C:\" & Filename
    On Error GoTo 0
    WB.SaveAs Filename:="C:\" & Filename

    Set OutlookApp = CreateObject("Outlook.Application")
    Set Mess = OutlookApp.CreateItem(olMailItem)
    With Mess
    .Subject = (newDate + " Matrix")
    .Body = ("Attached is your " + newDate + " bonus matrix.  Thanks! Neil")
    .to = Recip
    .Attachments.Add WB.FullName
    .Display
    .Send
    End With
    ActiveWorkbook.Close

    Set OutlookApp = Nothing
    Set Mess = Nothing

End Sub