excel rows with 2 emails split into 2 rows

November 23, 2010 at 14:42:45
Specs: Windows XP
I have rows something like so:
A B C
1 | john@domain.com; john.smith@domain.com | John | Smith
2 | david@domain.com | David | Smith
3 | carol@domain.com | Carol | Sanders
4 | james@domain.com | James | White
5 | peter@domain.com; peter.joe@hotmail.com | Peter | Black


There are about 4500 rows with names and email addresses and some have 2 emails on one line separated by a semi-colon.

What I'd like it to look like is:

A B C
1 | john@domain.com | John | Smith
2 | john.smith@domain.com | John | Smith
3 | david@domain.com | David | Smith
4 | carol@domain.com | Carol | Sanders
5 | james@domain.com | James | White
6 | peter@domain.com | Peter | Black
7 | peter.joe@hotmail.com | Peter | Black

Can someone please help me find a way to automate this?

Thank you


See More: excel rows with 2 emails split into 2 rows

Report •

#1
November 23, 2010 at 17:12:19
First, I have a favor to ask:

Please read the How To referenced in my signature line the next time you need to post data in the forum. By following the instructions in the How To you can make the data a lot easier for us to read.

                   A                         B     C
1  john@domain.com; john.smith@domain.com  John   Smith
2  david@domain.com                        David  Smith
3  carol@domain.com                        Carol  Sanders
4  james@domain.com                        James  White
5  peter@domain.com; peter.joe@hotmail.com Peter  Black

Try this code in a backup copy of your workbook since macros can not be undone.

Option Explicit
Sub CleanUpEmails()
Dim lastRw, rw As Integer
'Determine last row with data
  lastRw = Range("A" & Rows.Count).End(xlUp).Row
'Insert a new Column B
  Columns("B").Insert
'Split email addresses into 2 columns
  Range("A1:A" & lastRw).TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
        Semicolon:=True, Space:=True
'Loop from bottom to top
  For rw = lastRw To 1 Step -1
'If column B is an email address...
    If Cells(rw, 2) Like "*@*" Then
'Insert a row above it
      Cells(rw, 2).EntireRow.Insert
'Copy email address from Column A to new row
      Cells(rw + 1, 1).Copy Destination:=Cells(rw, 1)
'Copy last and First name to new Row
      Range(Cells(rw + 1, 3), Cells(rw + 1, 4)).Copy Destination:=Cells(rw, 2)
'Delete Copied Email address and shift cell left
      Cells(rw + 1, 1).Delete shift:=xlToLeft
'If Column B is Blank, delete the cell
    Else
      Cells(rw, 2).Delete shift:=xlToLeft
    End If
  Next
End Sub

Posting Tip: Before posting Data or VBA Code, read this How-To.


Report •
Related Solutions


Ask Question