Macro for flexible 'Text to Columns'/Transpose rows to columns/copy down cell data?

[wdkwang]

Hi everyone,
I've unsuccessfully tried to leverage the coding from other threads for what I need completed. Basically I have a very long spreadsheet of account numbers in column A and email addresses in column B. The email addresses are all grouped together in one cell, separated by a comma, and each row has a different amount as seen in my example below.
So the macro needs to be able to adjust for the different amount of emails when doing 'Text to Columns', transpose each email to the cell below, and have the associated account number copied down.
I would greatly appreciate it if someone could help me with this as it would save a large amount of time.


What it looks like now:

----------A-----------------B------------
1---123456789--john.doe@abc.com,janedoe@hi.com
2---234567890--aiden@abc.com
3---987654321--eric@wer.com,harry@lol.com,own@pwn.com,que@what.com,hungry@man.com
4---876543210--so@tired.com,omg@need.com,sleep@bed.com

What it needs to be:

----------A-----------------B------------
1---123456789--john.doe@abc.com
2---123456789--janedoe@hi.com
3---234567890--aiden@abc.com
4---987654321--eric@wer.com
5---987654321--harry@lol.com
6---987654321--own@pwn.com
7---987654321--que@what.com
8---987654321--hungry@man.com
9---876543210--so@tired.com
10--876543210--omg@need.com
11--876543210--sleep@bed.com

 

[igold]

Hi wdkwang,

See if this does what you are looking for.

Sub StripEmail()


    Dim nam As Variant
    Dim em As String
    Dim Lrow As Long
    Dim i As Integer, emct As Integer, e As Integer
    
    Application.ScreenUpdating = False
    Lrow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = Lrow To 1 Step -1
        em = Range("B" & i).Value
        nam = Split(em, ",")
        emct = UBound(nam)
        If emct = 0 Then GoTo OnlyOne
        Rows(i & ":" & i + UBound(nam) - 1).EntireRow.Insert
        Range("A" & i + UBound(nam) - 1 & ":" & "A" & i).Value = Cells(i, 1).Offset(UBound(nam), 0).Value
        For e = LBound(nam) To UBound(nam)
            Range("B" & i + e).Value = nam(e)
        Next
OnlyOne:
    Next
    Application.ScreenUpdating = True
End Sub

HTH

igold