Extract name and company from email address

M

martel_9

New Member
Joined
Jul 5, 2022
Messages
9
Office Version
  1. 365
  2. 2021
Platform
  1. Windows
  2. Mobile
I am working to organize a contact list, by using the email id as a reference point to extract the name (first & last) with the company name and set a unique serial number for each company name.
I found some valuable formulas to achieve the attached design. However, it requires specifying a fixed range to work with, while I need the list to be dynamic and work each time I add a new email id to the contact list.

I wrote a VBA input box to get the email id and paste it at the end of column E, and stucked for the rest :(
Appreciate your help and support.
 

Attachments

  • email.jpg
    email.jpg
    67 KB · Views: 29

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
Cannot manipulate data in a picture. Please reload your source data using XL2BB. Also show a mocked up solution based upon your source data.
 
Upvote 0
alansidman said:
Cannot manipulate data in a picture. Please reload your source data using XL2BB. Also show a mocked up solution based upon your source data.
Click to expand...
Contact Database.xlsm
ABCDE
1Company CodeFirst NameLast NameCompany NameContact Email
21FnameLnameHotmailfname.lname@hotmail.com
3FnameLnameMsnFname2.Lname@msn.com
4Fname YahooFname.Lname35@yahoo.com
5FnameLnameGmailFname.Lname@gmail.com
6#VALUE!FnamelnameHotmailFnameLname@hotmail.com
7FnameLnameMsnFname_Lname@msn.com
8FnameLnameHot-MailFname_Lname@hot-mail.com
9FnameLnameYahooFname-Lname@yahoo.co.uk
Formula
Cell Formulas
RangeFormula
B2:B9B2=MID(H2,1,MIN(IF(ISERROR(SEARCH(MID(H2,ROW($2:$9000),1),"qwertyuiopasdfghjklzxcvbnm")),ROW($2:$9000)))-1)
C2:C9C2=MID(H2,MAX(IF(ISERROR(SEARCH(MID(H2&REPT("a",100),ROW($2:$9000),1),"qwertyuiopasdfghjklzxcvbnm")),ROW($2:$9000)))+1,99)
D2:D9D2=PROPER(LEFT(REPLACE(E2,1,FIND("@",E2),""),FIND(".",REPLACE(E2,1,FIND("@",E2),""))-1))
Press CTRL+SHIFT+ENTER to enter array formulas.
 
Upvote 0
alansidman said:
Cannot manipulate data in a picture. Please reload your source data using XL2BB. Also show a mocked up solution based upon your source data.
Click to expand...
Thanks alansidman for viewing the post and for your advice.
 
Upvote 0
I aim to have a unique serial number for non-duplicate company names as the attached image, and do not have any clue to do so.
 
Upvote 0
You can iterate through a dynamic table with this code:

VBA Code: 
Dim i As Integer
Dim finalRow As Long

'This sets the end range of your dataset
finalRow = Range("E" & Rows.Count).End(xlUp).Row

'i is the starting row you want to iterate through
For i = 5 To finalRow
   'Do stuff
Next



Not particularly pretty, but does the job - don't usually use ActiveCell.FormulaR1C1. Quick and dirty comes at a cost, but gives you something that play with. :-)

VBA Code: 
Sub DoSomething()

Application.ScreenUpdating = False

Dim i As Integer
Dim finalRow As Long

finalRow = Range("E" & Rows.Count).End(xlUp).Row

For i = 5 To finalRow

    'Lookup for Company Code
    Range("A" & i).Select
    ActiveCell.FormulaR1C1 = "=XLOOKUP(RC[3],C[11],C[10],""Not Found"",0)"
    
    Range("B" & i).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""."",RC5))))-1),IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1)" & _
    ")))),TRUE))=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""_"",RC5))))-1),IF(IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=TRUE,IF(ISERROR(FIND(""-"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND" & _
    "(""@"",RC5))))-1))))),TRUE))=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""-"",RC5))))-1),LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))" & ""
    
    Range("C" & i).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""."",RC5)),IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-F" & _
    "IND(""@"",RC5))))-1))))),TRUE))=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""_"",RC5)),IF(IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=TRUE,IF(ISERROR(FIND(""-"",((LEFT(R" & _
    "C5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""-"",RC5)),"""")))" & ""
    
    Range("D" & i).Select
    ActiveCell.FormulaR1C1 = "=PROPER(LEFT(REPLACE(RC[1],1,FIND(""@"",RC[1]),""""),FIND(""."",REPLACE(RC[1],1,FIND(""@"",RC[1]),""""))-1))"
Next

Range("A5:D" & finalRow).Select
Selection.Copy
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Range("A1").Select

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub
 

Attachments

  • 220818-145711.jpg
    220818-145711.jpg
    163.5 KB · Views: 25
Upvote 0
MaxD said:
VBA Code: 
Sub DoSomething()

Application.ScreenUpdating = False

Dim i As Integer
Dim finalRow As Long

finalRow = Range("E" & Rows.Count).End(xlUp).Row

For i = 5 To finalRow

    'Lookup for Company Code
    Range("A" & i).Select
    ActiveCell.FormulaR1C1 = "=XLOOKUP(RC[3],C[11],C[10],""Not Found"",0)"
   
    Range("B" & i).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""."",RC5))))-1),IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1)" & _
    ")))),TRUE))=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""_"",RC5))))-1),IF(IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=TRUE,IF(ISERROR(FIND(""-"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND" & _
    "(""@"",RC5))))-1))))),TRUE))=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""-"",RC5))))-1),LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))" & ""
   
    Range("C" & i).Select
    ActiveCell.FormulaR1C1 = _
    "=IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""."",RC5)),IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-F" & _
    "IND(""@"",RC5))))-1))))),TRUE))=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""_"",RC5)),IF(IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=TRUE,IF(ISERROR(FIND(""-"",((LEFT(R" & _
    "C5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""-"",RC5)),"""")))" & ""
   
    Range("D" & i).Select
    ActiveCell.FormulaR1C1 = "=PROPER(LEFT(REPLACE(RC[1],1,FIND(""@"",RC[1]),""""),FIND(""."",REPLACE(RC[1],1,FIND(""@"",RC[1]),""""))-1))"
Next

Range("A5:D" & finalRow).Select
Selection.Copy
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Range("A1").Select

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub
Click to expand...

Many thanks @MaxD for your great help. It works like a charm.
I changed the for loop to start the row 2 (For i = 2 to finalRow).

Now, I am struggle to generate a unique serial number code for each company.
In case the company was not listed, add a new code (serial number), and if the company name exists, the code should take its code number.
 

Attachments

  • email.jpg
    email.jpg
    67 KB · Views: 19
Upvote 0
Thank you @MaxD again for your effort.
I completed the vba code for the rest of the sheet, and would like to share it here for everyone.

The below vba Command Button Code is taking the email ID and get the First Name, Last Name and Company Name.
Distinguish the name by multi-separators like (. dot, _ under-score, - dash), and the company name from the email domain name.

Set a unique serial number based on a sorted list of unique company names in column (K and L).

Enjoy everyone



VBA Code: 
Private Sub CommandButton1_Click()
    Dim i As Integer
    Dim finalRow, uqfinalRow As Long        'finalRow for the email Table, uqfinalRow for the unique company code values
    
    finalRow = Range("E" & Rows.Count).End(xlUp).Row
    
    For i = 2 To finalRow
        Range("A" & i).Select       'Lookup for Company Code
        ActiveCell.FormulaR1C1 = "=XLOOKUP(RC[3],C[11],C[10],""Not Found"",0)"
        
        Range("B" & i).Select       'Lookup for First Name
        ActiveCell.FormulaR1C1 = _
        "=PROPER(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""."",RC5))))-1),IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1)" & _
        ")))),TRUE))=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""_"",RC5))))-1),IF(IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=TRUE,IF(ISERROR(FIND(""-"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND" & _
        "(""@"",RC5))))-1))))),TRUE))=FALSE,LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""-"",RC5))))-1),LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1)))))" & ""
        
        Range("C" & i).Select       'Lookup for Last Name
        ActiveCell.FormulaR1C1 = _
        "=PROPER(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""."",RC5)),IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-F" & _
        "IND(""@"",RC5))))-1))))),TRUE))=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""_"",RC5)),IF(IF(IF(IF(ISERROR(FIND(""."",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE)=TRUE,IF(ISERROR(FIND(""_"",((LEFT(RC5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=TRUE,IF(ISERROR(FIND(""-"",((LEFT(R" & _
        "C5,LEN(RC5)-LEN((RIGHT(RC5,LEN(RC5)-FIND(""@"",RC5))))-1))))),TRUE))=FALSE,RIGHT(LEFT(RC5,FIND(""@"",RC5)-1),LEN(LEFT(RC5,FIND(""@"",RC5)-1))-FIND(""-"",RC5)),""""))))" & ""
        
        Range("D" & i).Select       'Lookup for Company Name
        ActiveCell.FormulaR1C1 = "=PROPER(LEFT(REPLACE(RC[1],1,FIND(""@"",RC[1]),""""),FIND(""."",REPLACE(RC[1],1,FIND(""@"",RC[1]),""""))-1))"
    Next
    
    'Copy the filter results (Unique Company names) from column D to column L
    Range("D:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L1"), Unique:=True
    Range("L:L").Sort Key1:=Range("L2"), order1:=xlAscending, Header:=xlNo  'Sort thr result
    

    'Count the unique company names
    uqfinalRow = Range("L" & Rows.Count).End(xlUp).Row                      'Count the number of unique values (company names)
    
    '   '''''Auto Sr. Quotation Table
    Range("K2").Activate                                                    'Starting cell
    
    For i = 1 To uqfinalRow - 1
        If ActiveCell.Offset(-1, 0).Value = "Code" Then                     'If you find "code" in the K1
            ActiveCell.Offset(0, 0).Value = "1"                             'Start the serial number from 1 in K2
        Else
            ActiveCell.Offset(0, 0).Value = "=@INDIRECT(ADDRESS(ROW()-1,COLUMN()))+1"       'Add +1 on the above number
        End If
        ActiveCell.Offset(1, 0).Select                                                      'Select the next cell in the row
    Next i
    
    
    Range("B2:D" & finalRow).Select         'Copy and paste values for the range A to D (company code, F name, L name, company name)
    Selection.Copy
    
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    
    Range("K2:K" & uqfinalRow).Select       'Copy and paste values for the range K (company code, company name)
    Selection.Copy
    Range("K2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    Range("A" & finalRow).Offset(1, 0).Select
End Sub



Rich (BB code): 
Contact Database.xlsm
ABCDEFGHIJKL
1CodeFirst NameLast NameCompany NameContact EmailCodeCompany Name
22FnameLnameHotmailfname.lname@hotmail.com1Gmail
34Fname2LnameMsnFname2.Lname@msn.com2Hotmail
45FnameLname35YahooFname.Lname35@yahoo.com3Hot-Mail
51FnameLnameGmailFname.Lname@gmail.com4Msn
62FnamelnameHotmailFnameLname@hotmail.com5Yahoo
74FnameLnameMsnFname_Lname@msn.com
83FnameLnameHot-MailFname_Lname@hot-mail.com
95FnameLnameYahooFname-Lname@yahoo.co.uk
Sheet2
Cell Formulas
RangeFormula
K3:K6K3=INDIRECT(ADDRESS(ROW()-1,COLUMN()))+1
A2:A9A2=XLOOKUP(D2,L:L,K:K,"Not Found",0)
Named Ranges
NameRefers ToCells
Extract=Sheet2!$L$1A2:A9
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

P
  • Question Question
Extract first and last name from email & Runtime error 13 type mismatch
Replies
2
Views
238
Alex Blakenburg
A
N
  • Question Question
VBA to add title from formula to a save as name
Replies
0
Views
96
NKUNZI
N
R
  • Question Question
Inserting a mailto link into an email body to a customer, based on a cell value.
Replies
3
Views
1K
Domenic
D
G
  • Solved
How to filter a table with two email columns against a list of emails
Replies
7
Views
692
dreid1011
dreid1011
J
  • Question Question
Power Query editor OR VBA to extract data from Grants.gov
Replies
3
Views
355
Jagadeshrao
J

Forum statistics

Threads
1,223,888
Messages
6,175,205
Members
452,618
Latest member
Tam84

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top