Populating the .to for an automated email from a range matching a value-CodePudding

I have this sheet called "Distribution" that contains the name of the project and the emails associated with the project. I am creating an automated email but need to include all the emails for that project. I currently have the names hard coded in the .to like this: .To = "[email protected]; [email protected]; [email protected]"

But would like to know how I can use VBA code to match the value in a worksheet called "Loans" where the project name is in column F. I know that I can use ActiveSheet.Range("F" & ActiveCell.Row).Value to get the project name but how do I add the email address in worksheet "Distribution" that match the project name?

CodePudding user response：

Well you could select it with a user-form like so:

This is the code I used in the user-form, I names the select button Engage because I couldn't use Select as it's a restricted name. Then CancelOP is the cancel button.

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

I decided to store the selected project as a global variable, although I probably didn't have to: SelectedItem. And I decided to make the whole sub a string function so it can be used in the main sub as the list of emails. Here is the whole function (I included the sub I used to test it):

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

Example:

Option 2: No User Form, Activecell Method

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