Question

我想将多个收件人和附件添加到由一列中的值决定的一封电子邮件中。

我需要让人们更新他们的简历，该简历将随函附上，但我想按经理对电子邮件进行分组。每位经理下的人数为1-14。

我的专栏是：
B：经理电子邮件地址
C：经理姓氏
D：员工电子邮件
E：Emp名字
F：Emp姓氏
G：简历状态

我创建了一个宏，该宏将循环遍历并为每个条目创建带有适当附件的电子邮件。

我想通过C或B列中的值将其切换为雇员组。我暗示这将包括数组。我是VBA新手。

到目前为止，我所拥有的（为隐私而重命名的特定路径/电子邮件）：

Sub Test2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim sSourcePath As String
Dim flpath As String
flpath = "C:\Resumes\"

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    'XYZ email address was hardcoded for testing purposes, but should also loop
    If cell.Value = "XYZ@gmail.com" And _
       Cells(cell.Row, "G").Value = "4. Need Update" _
       Then

        Set OutMail = OutApp.CreateItem(0)
        sSourcePath = Dir(flpath & Cells(cell.Row, "E").Value & " *.docx")

        On Error Resume Next
        With OutMail
            .To = cell.Value & ", " & Cells(cell.Row, "D").Value
            'cced address is static
            .CC = "ZZZ@gmail.com" 
            .Subject = "Resume needed"
            .body = "Howdy!" _
                  & vbNewLine & vbNewLine & _
                    "Body text"

            .attachments.Add flpath & sSourcePath
            .Display  'Or use Display

        End With
        On Error GoTo 0
        Set OutMail = Nothing
    End If

Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

如果我正确地猜到了您想要什么，这是一种使用经理收集的电子邮件的方法。它们随您创建，然后完成后，您可以对集合中的消息进行任何操作。

Dim allMessages as Collection
Dim currMessage as Object
Set allMessages = New Collection

For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    If Cells(cell.Row, "G").Value = "4. Need Update"
        ' Find the e-mail for the present manager
        For Each currMessage in allMessages
            If currMessage.CC = cell.Value Then
                Exit For
            End If
        Next currMessage

        ' Create it, if it wasn't found
        If currMessage Is Nothing Then
            Set currMessage = OutApp.CreateItem(0)
            allMessages.Add currMessage
            With currMessage
                .CC = cell.Value
                .Subject = "Résumé Needed"
                .Body = "Howdy!" & vbNewLine & vbNewLine & "Body text."
            End With
        End If

        ' Add the Message Recipient and Attachment
        sSourcePath = Dir(flpath & Cells(cell.Row, "E").Value & " *.docx")
        With currMessage
            .To = .To & Iif(Len(.To) > 0,";","") & _
                  cell.Value & ", " & Cells(cell.Row, "D").Value
            .Attachments.Add flpath & sSourcePath
        End With

        Set currMessage = Nothing

    End If
Next cell

' Now do something with the messages.
For Each currMessage In allMessages
    currMessage.Display
End If

Set currMessage = Nothing
Set allMessages = Nothing

注意事项：：由于我目前没有您的数据并且目前不使用Outlook，因此我尚未测试上述代码段。该代码段主要用一个附加循环替换了For...Next循环，并在结尾处进行了清理，并在开头进行了一些声明。让我知道它是否给您带来问题，我将根据您告诉我的情况尝试解决此问题。

使用Excel VBA根据通用单元格值将电子邮件发送给多个人

1 个答案: