CODEWITHSUNDEEP
excelvba
Maluc
Maluc

Reputation: 145

Converting a Column with a list of names into a string with associated email

I have a list of peoples names in a column (on sheet 12) and in that column each cell can have one or more person inside of it separated by a comma and and an alt+enter. What I want to do is take the contents of this column, convert it into a list of emails, and then convert this into a single string which only has unique entries with the peoples email addresses (i.e. if the name is repeated in the column, after the persons email has been added it does not get included in the string again).

I would like to avoid including an additional column in the sheet with the emails, so I have another tab with a list of peoples names against their email addresses which I used an index match to obtain the emails with.

The below code is the only way I can think of doing it but as the number of people in each cell increases the number of possible combinations increases so it gets too unwieldy to create, hence, I have come here in the hopes there is a way to overcome this.

Sub Macro1()

Dim i As Integer
Dim P As Integer
Dim Email_To As String
Dim Email_Rng As Range
Dim Num_of_Emails As Integer
Dim Last_Cell_TWDS As Integer
Dim Last_Cell_TWDP As Integer
Dim Last_Cell_RCAR As Integer
Dim Last_Cell_Specs As Integer
Dim Last_Cell_Minutes As Integer
Dim First_Row As Integer
Dim Owner_Column As Integer
Dim Email_Check As String
Dim Email_Check_P1 As String
Dim Email_Check_P2 As String
Dim Email_Check_P3 As String
Dim Email_Check_P4 As String
Dim Num_People_Cell As Integer
Dim Cell_Value As String
Dim P1 As String
Dim P2 As String
Dim P3 As String
Dim P4 As String

'Setting Email to to empty
Email_To = ""

'Email to TWDS
    Sheet12.Select
    Last_Cell_TWDS = Range("Admin!U2").Value
    First_Row = 5
    Owner_Column = 5
    Email_Check = ""
    
    For i = First_Row To (Last_Cell_TWDS + 4)
    
    If Cells(i, Owner_Column).Value <> "" Then 'check if the cell is empty and if not set the cell value to check the email
        
        Num_People_Cell = Len(Cells(i, Owner_Column).Value) - Len(Replace(Cells(i, Owner_Column).Value, ",", "")) + 1 ' Checking the number of people in the cell using the number of commas
        
    End If
    
        If Cells(i, Owner_Column).Value <> "" Then 'check if the cell is empty and if not set the cell value to check the email

            For P = 1 To Num_People_Cell ' +1 because 2 people = 1 comma
            
               If P = 1 Then '////////////////////////////////////////////////////////////////////////////////////////////1 Person
               
                    If Num_People_Cell = 1 Then
                    
                        Email_Check = WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(Cells(i, Owner_Column).Value, Range("Admin!P4:P200"), 0)) 'define what the current email is for the name in the cell
                        
                    End If
            
                     If Cells(i, Owner_Column).Value = "" Then ' if the cell is Blank do nothing
                         Email_To = Email_To
             
                     ElseIf Email_To = "" Then 'if the cell is not blank then take the contents of the cell and add it to email_To string
                     
                             Email_To = Email_To & WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(Cells(i, Owner_Column).Value, Range("Admin!P4:P200"), 0))
                         
                     ElseIf InStr(1, Email_To, Email_Check) <> 0 Then 'if Email_To is not blank then check if the cell value is already in the Email_To string
                         
                             Email_To = Email_To
                         
                     Else
                         
                         Email_To = Email_To & "; " & WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(Cells(i, Owner_Column).Value, Range("Admin!P4:P200"), 0))
                         
                    End If
                 
                ElseIf P = 2 Then '////////////////////////////////////////////////////////////////////////////////////////////2 People
                 
                     'define the two peoples names
                     P1 = Left(Cells(i, Owner_Column).Value, InStr(1, Cells(i, Owner_Column).Value, ",") - 1)
                     P2 = Right(Cells(i, Owner_Column).Value, (Len(Cells(i, Owner_Column).Value) - 3 - InStr(1, Cells(i, Owner_Column).Value, ",")))
                     Email_Check_P1 = WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P1, Range("Admin!P4:P200"), 0)) 'define what the current email is for the name in the cell
                     Email_Check_P2 = WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P2, Range("Admin!P4:P200"), 0)) 'define what the current email is for the name in the cell
                     
                     If Email_To = "" Then 'if the cell is not blank then take the contents of the cell and add it to email_To string
                     
                             Email_To = P1 & "; " & P2
                         
                    ElseIf InStr(1, Email_To, Email_Check_P1) <> 0 And InStr(1, Email_To, Email_Check_P2) <> 0 Then
                         
                         Email_To = Email_To
                         
                    ElseIf InStr(1, Email_To, Email_Check_P1) = 0 And InStr(1, Email_To, Email_Check_P2) = 0 Then
                         
                         Email_To = Email_To & "; " & WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P1, Range("Admin!P4:P200"), 0)) & "; " & WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P2, Range("Admin!P4:P200"), 0))
                    
                    ElseIf InStr(1, Email_To, Email_Check_P1) > 0 Then
                         
                         Email_To = Email_To & "; " & WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P1, Range("Admin!P4:P200"), 0))
                         
                    ElseIf InStr(1, Email_To, Email_Check_P2) > 0 Then
                         
                         Email_To = Email_To & "; " & WorksheetFunction.Index(Range("Admin!Q4:Q200"), WorksheetFunction.Match(P2, Range("Admin!P4:P200"), 0))
                         
                    End If

                End If
            
            Next P
        
        End If
        
    Next i

End Sub

Upvotes: 1

Views: 273

Answers (1)

Tim Williams
Tim Williams

Reputation: 166511

This might be a way to handle it:

EDIT: added getting a single string with all unique mails

Sub Tester()
    
    Dim c As Range, v, arr, nm, email, emails, sep
    Dim dict As Object, rngEmails As Range
    
    Set dict = CreateObject("scripting.dictionary") 'for tracking unique values
    
    'email lookup table: name|email
    Set rngEmails = ThisWorkbook.Sheets("Admin").Range("P4:Q4")

    For Each c In sheet12.Range("E5:E" & sheet12.Cells(Rows.Count, "E").End(xlUp).Row)
        v = c.Value
        If Len(v) > 0 Then                    'ignore empy cells
            v = Replace(v, vbLf, ",")         'get a single thing to split on...
            arr = Split(v, ",")               'get an array of names
            For Each nm In arr                'loop over the array
                nm = Trim(nm)                 'remove leading/trailing spaces
                If Not dict.exists(nm) Then   'if a new name then get the email
                    email = Application.VLookup(nm, rngEmails, 2, False)
                    If Not IsError(email) Then
                        dict(nm) = email
                    Else
                        Debug.Print "No email found for '" & nm & "'"
                    End If
                End If
            Next nm
        End If
    Next c

    emails = Join(dict.items, ";") 'get single string from dictionary items
    'do something with `emails`
    
End Sub

Upvotes: 1

Related Questions