excel - 如何使用下拉列表向多个收件人发送电子邮件？

Question

我正在尝试向 .CC 中的一群人发送一封电子邮件.
我有一个名为“项目”的 Excel 工作表，其中包含联系人组名称的下拉列表。
worker 1 类(地址 B2)，在另一个名为“联系人”的工作表上，我在列中有电子邮件列表，其中第一行是上述组的名称(标题地址 A2:AX2)。
我想从下拉列表中选择电子邮件组并向列表中的每个人发送一封电子邮件。现在我有一个必须手动选择范围的输入框。

Sub EmailCC()

    Dim xOTApp As Object
    Dim xMItem As Object
    Dim xCell As Range
    Dim xRg As Range
    Dim xEmailAddr As String
    Dim xTxt As String

    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Address list:", "Range", xTxt, , , , , 8)

    If xRg Is Nothing Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")

    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next

    Set xMItem = xOTApp.CreateItem(0)

    With xMItem
        .To = " "
        .CC = xEmailAddr
        .Display
    End With

End Sub

Excel file with macro example

Answer 1

一些建议:

除非绝对必要，否则不要使用 On Error Resume Next

将变量命名为有意义的名称(使用 contactsHeaderRange 而不是 xRG )

评论您的代码

分步拆分代码

阅读 Code 的注释并根据您的需要进行调整
编辑:从每个地址一封电子邮件更改为一封电子邮件中的所有地址

Public Sub SendEmailsByGroup()
    
    Dim projectSheet As Worksheet
    Set projectSheet = ThisWorkbook.Worksheets("Project")
    
    Dim groupCell As Range
    Set groupCell = projectSheet.Range("B2")
    
    Dim groupName As String
    groupName = groupCell.Value
    
    Dim contactsSheet As Worksheet
    Set contactsSheet = ThisWorkbook.Worksheets("Contacts")
    
    Dim contactsHeadersRange As Range
    Set contactsHeadersRange = contactsSheet.Range("A2:C2")
    
    ' Get header according to group name
    Dim contactsGroupHeader As Range
    Set contactsGroupHeader = contactsHeadersRange.Find(groupName)
    
    ' If the group is not found, cancel the process
    If contactsGroupHeader Is Nothing Then
        MsgBox "Group name not selected or found"
        Exit Sub
    End If
    
    ' Get group email values from range (use transpose to pass the range to a 1D array)
    Dim groupEmails As Variant
    groupEmails = Application.Transpose(contactsSheet.Range(contactsGroupHeader.Offset(1, 0), contactsSheet.Cells(contactsSheet.Rows.Count, contactsGroupHeader.Column).End(xlUp)).Value)
    
    SendEmails groupEmails
    

End Sub

Private Sub SendEmails(ByVal groupEmails As Variant)

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    
    Dim mailItem As Object
    Set mailItem = outlookApp.CreateItem(0)
    
    Dim emailsList As String
    emailsList = Join(groupEmails, ";")
    
    With mailItem
        '.To =
        .CC = emailsList
        .Display
    End With
    
    
End Sub

让我知道它是否有效