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

Question

我正在尝试向 .CC 中的一群人发送一封电子邮件。

我有一个名为“项目”的 Excel 工作表，带有包含联系人组名称的下拉列表。

工人 1 班（地址 B2），在另一个名为“联系人”的工作表上，我在列中有电子邮件列表，其中第一行是上述组的名称（标题地址 A2:AX2）。

我想从下拉列表中选择电子邮件组，并向列表中的每个人发送一封电子邮件。现在我有一个输入框，我必须手动 select。

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

你好试试这个：在项目 sheet 上放一个下拉列表。像这样：drop down list in Excel

和代码：

Option Explicit
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
    Dim w As Workbook
    Dim sProject As Worksheet
    Dim sContacts As Worksheet
    Dim i As Integer
    Dim column  As Integer
    Set w = ActiveWorkbook
    Set sProject = w.Sheets(1)
    Set sContacts = w.Sheets(2)
    On Error Resume Next
    column = sProject.Cells(3, 9).Value
    If Not (IsNumeric(column)) Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")
    i = 3
    Do While Not sContacts.Cells(i, column).Value = ""
                xEmailAddr = sContacts.Cells(i, column).Value & ";" & xEmailAddr
                i = i + 1
    Loop
    Set xMItem = xOTApp.CreateItem(0)
    With xMItem
        .To = " "
        .CC = xEmailAddr
        .Display
    End With
End Sub

Excel file

Answer 2

一些建议：

除非绝对必要，否则不要使用 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

如果有效请告诉我

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

How to send email to multiple recipients with drop down list?

excel

outlook

vba