Formula/Macro to convert email address(es) copied from Outlook to only first and last names

[REvans81]

Hello,
This might be a dumb question... I've gotten part of the way there. I'd like a formula or macro to convert email address(es) copied from Outlook to a 'display name'.

Column A = Email(s) pasted from Outlook
Column B = Sanitized names

Input Examples:
Last, First <username@domain.com>
Last, First <username@domain.com>; Last, First Middle <username@domain.com>

Output Examples:
First Last
First Last, First Last

I found a way to strip out the email SUBSTITUTE(cell,MID(LEFT(cell,FIND(">",cell)),FIND("<",cell),LEN(cell)),"") and how to reverse the names MID(cell&" "&cell,FIND(", ",cell)+2,LEN(cell)-1) but I'm not really sure what to do from here.



I want users to be able to paste email addresses from Outlook into column A and have column B show just the first and last names, comma delimited. I'm using a macro to populate an email template that will utilize these email addresses in the TO field, but I want the spreadsheet to just show the names.


Thank you!

 

[sijpie]

The two formulas work fine for addresses on a single line. But I am assuming you are stuck with the second example where you have two (or more) addresses on one line.

As you are working with macros anyway, you can have a macro create the first Last list as soon as someone pastes (or adds) a list of addresses.

The following macro assumes the list starts in cell A1, and there is a heading in A1 and B1.

Right click on the sheet name tab and select 'View code...'
The vba editor will open in the module for this sheet. Here you can capture the events happening on the sheet. You want to capture the Worksheet_Change event:

Option Explicit

'this macro checks for changes to the A column. It then splits out _
 email addresses (outlook format) adding a Firstnam Lastname column
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim vIn As Variant, vOut As Variant, vUBi As Long
    Dim lRi As Long, lRo As Long, lCnt As Long
    Dim sAddr As String
    Dim c As Integer, l As Integer
    
    'check if column A is changed
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        'load the column A (and any other columns in the current _
         region) into input array for fast processing. Only column A is used
        vIn = Range("A1").CurrentRegion.Value
        If IsEmpty(vIn) Then Exit Sub   'column was deleted
        vUBi = UBound(vIn, 1)
        
        ' count number of email addresses in list. if more on one line separated by ';'
        For lRi = 2 To vUBi 'skip header line
            If vIn(lRi, 1) Like "*;*" Then
                'more addresses on one line
                lCnt = lCnt + CountAddr(CStr(vIn(lRi, 1)))
            Else
                lCnt = lCnt + 1
            End If
        Next lRi
        
        'size the output array to acommodate all the addresses
        ReDim vOut(1 To lCnt + 1, 1 To 2)
        'copy the headers of column A and B
        vOut(1, 1) = vIn(1, 1): vOut(1, 2) = vIn(1, 2)
        lRo = 2
        'Work through each row of the input array
        For lRi = 2 To vUBi
            sAddr = CStr(vIn(lRi, 1))
            ' check if more than one address on the row
            If sAddr Like "*;*" Then
                Do
                    c = c + 1
                    l = c
                    c = InStr(c, sAddr, ";")
                    ' get Outlook format address of each person
                    vOut(lRo, 1) = Trim(Mid(sAddr, l, IIf(c, c - l, Len(sAddr))))
                    'get Firstname Lastname of the person
                    vOut(lRo, 2) = FirstLast(CStr(vOut(lRo, 1)))
                    lRo = lRo + 1
                Loop While c
            Else
                vOut(lRo, 1) = vIn(lRi, 1)
                vOut(lRo, 2) = FirstLast(Trim(sAddr))
                lRo = lRo + 1
            End If
        Next lRi
        
        'now overwrite input address table with split list and names
        'first avoid recalling this worksheet_chanfge event
        Application.EnableEvents = False
        'dump the output array
        Range("A1").Resize(lCnt, 2).Value = vOut
        'then reactivate events
        Application.EnableEvents = True

    End If
End Sub



Function CountAddr(sAddrLine As String) As Integer
'count number of addresses on a line
    Dim i As Integer, c As Integer
    
    Do
        c = c + 1
        c = InStr(c, sAddrLine, ";")
        i = i + 1
    Loop While c
    CountAddr = i
    
End Function

Function FirstLast(sAddr As String) As String
' modify Outlook address into "Firstname LastName"
    Dim sF As String, sL As String
    
    sL = Left(sAddr, InStr(1, sAddr, ",") - 1)
    sF = Trim(Mid(sAddr, Len(sL) + 2, InStr(1, sAddr, "<") - Len(sL) - 2))
    FirstLast = sF & " " & sL
End Function