从匹配值的范围填充自动 email 的.to

Question

我有一张名为“分发”的工作表，其中包含项目名称和与项目相关的电子邮件。 我正在创建一个自动化的 email，但需要包括该项目的所有电子邮件。 我目前将名称硬编码在.to 中，如下所示：.To = "ana.chiriboga@lgihomes.com; trey.williams@lgihomes.com; fik.mesheka@lgihomes.com"

但想知道如何使用 VBA 代码来匹配名为“贷款”的工作表中的值，其中项目名称位于 F 列中。我知道我可以使用 ActiveSheet.Range("F" & ActiveCell.Row)。获取项目名称的值，但如何在工作表“分布”中添加与项目名称匹配的 email 地址？

Answer 1

那么你可以 select 像这样的用户表单：

这是我在用户表单中使用的代码，我将 select 按钮命名为Engage ，因为我不能使用Select ，因为它是一个受限名称。 那么CancelOP就是取消按钮。

Option Explicit

Private Sub CancelOp_Click()
    Unload Me
End Sub

Private Sub Engage_Click()

    Dim I As Integer

    For I = 0 To SelectionList.ListCount - 1
        If SelectionList.Selected(I) = True Then
            SelectedItem = (SelectionList.List(I))
        End If
    Next I
    
    Unload Me

End Sub

我决定将所选项目存储为全局变量，尽管我可能不必这样做： SelectedItem 。 我决定将整个子字符串设为 function，这样它就可以在主子中用作电子邮件列表。 这是整个 function（我包括了我用来测试它的子）：

Option Explicit
Public SelectedItem As String
Function Select_Project_Email_List() As String
    
    Dim Distribution As Worksheet
    Dim Dict As Scripting.Dictionary
    Dim RG As Range
    Dim CL As Range
    Dim Arr
    Dim EmailString As String
    Dim I As Long
    Dim sRow As Long
    Dim lRow As Long
    
    Set Distribution = ThisWorkbook.Worksheets("Distribution")
    Set Dict = New Scripting.Dictionary
    
    With Distribution
        Set RG = .Range("A1", .Range("B" & Rows.Count).End(xlUp).Offset(1, 0))
        For Each CL In RG.Columns(1).Cells
            If CL.MergeCells Then
                I = I + 1
                Dict.Add I, CL.Value
            End If
        Next CL
    
        ListSelector.SelectionList.List = Dict.Items
        ListSelector.Show

        Debug.Print SelectedItem
        sRow = RG.Find(SelectedItem).Row + 1
        lRow = RG.Find("", .Range("A" & sRow)).Row - 1
        Debug.Print sRow
        Debug.Print lRow
        Set RG = .Range("A" & sRow, "B" & lRow)
        Arr = RG
        
    End With
    
    EmailString = ""
    For I = 1 To UBound(Arr, 1)
        EmailString = EmailString & Arr(I, 2) & "; "
    Next I
    EmailString = Left(EmailString, Len(EmailString) - 2)
    Select_Project_Email_List = EmailString
    
End Function
Sub TestEmailList()

    Dim EmailList As String
    
    EmailList = Select_Project_Email_List
    
    Debug.Print EmailList
    MsgBox Replace(EmailList, " ", vbCrLf), vbOKOnly, "EmailList"
    
End Sub

---

例子：

---

选项 2：无用户表单，Activecell 方法

Sub Select_Project_Email_List_ActiveCell()
    
    Dim Distribution As Worksheet
    Dim Loans As Worksheet
    Dim Dict As Scripting.Dictionary
    Dim RG As Range
    Dim CL As Range
    Dim Arr
    Dim EmailString As String
    Dim SelectedItemAC As String
    Dim I As Long
    Dim sRow As Long
    Dim lRow As Long
    
    Set Distribution = ThisWorkbook.Worksheets("Distribution")
    Set Loans = ThisWorkbook.Worksheets("Loans")
    Set Dict = New Scripting.Dictionary
    
    With Distribution
        Set RG = .Range("A1", .Range("B" & Rows.Count).End(xlUp).Offset(1, 0))
        For Each CL In RG.Columns(1).Cells
            If CL.MergeCells Then
                I = I + 1
                Dict.Add I, CL.Value
            End If
        Next CL
    
        SelectedItemAC = ActiveCell.Value

        Debug.Print SelectedItemAC
        sRow = RG.Find(SelectedItemAC).Row + 1
        lRow = RG.Find("", .Range("A" & sRow)).Row - 1
        Debug.Print sRow
        Debug.Print lRow
        Set RG = .Range("A" & sRow, "B" & lRow)
        Arr = RG
        
    End With
    
    EmailString = ""
    For I = 1 To UBound(Arr, 1)
        EmailString = EmailString & Arr(I, 2) & "; "
    Next I
    EmailString = Left(EmailString, Len(EmailString) - 2)
    
    Call BuildEmail(EmailString)
    
End Sub
Sub BuildEmail(EmailString As String)
    
    Dim objOutlook As Object
    Dim objEmail As Object
    
    Set objOutlook = CreateObject("Outlook.Application")
    Set objEmail = objOutlook.CreateItem(olMailItem)
    
    With objEmail
        .To = EmailString
        .CC = ""
        .BCC = ""
        .Subject = "Email Subject"
        .Body = "Hello world"
        .Display
        '.Send
    End With

End Sub