Separate emails into bits through macro and text to columns

[Jyggalag]

Dear All,

I currently have a setup that looks approximately like this:

I would like to know if there is some record macro / VBA solution to separate the emails so email 1 goes into Column K, email 2 into column O and email 3 into column S?

I tried to record a macro and use "text to columns" under the data tab and almost got it, but it didnt work out and it was quite inflexible if I created a new set of three emails in cell J3 (above it is in cell J2) and applied the macro to it, which was unsuccessful, unfortunately.

Also, if there are only 2 emails in the cell, it would be nice if it could leave the last cell (cell S) blank.

Please note that I have a similar looking thread I posted 5 minutes ago, but it is a different question, therefore I have separated the questions. I hope that any moderator would agree with this decision or merge my questions if necessary.

Thank you for your time everybody!

Kind regards,
Jyggalag.

 

[Joe4]

Try this:

Sub SplitEmails()

    Dim lr As Long
    Dim r As Long
    Dim arr() As String
    Dim col(2) As String
    Dim i As Long
    
    Application.ScreenUpdating = False
    
'   Pre-populate column reference array
    col(0) = "K"
    col(1) = "O"
    col(2) = "S"
    
'   Find last row in column J with data
    lr = Cells(Rows.Count, "J").End(xlUp).Row
    
'   Loop through all rows starting at row 2
    For r = 2 To lr
'       Build array of email addresses
        arr = Split(Cells(r, "J"), ";")
'       Loop through and populate columns
        For i = LBound(arr) To UBound(arr)
            Cells(r, col(i)) = arr(i)
        Next i
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[JEC]

One other variant

Sub jec()
 Dim it, ar
 For Each it In Range("J2", Range("J" & Rows.Count).End(xlUp))
    ar = Split(Join(Split(it, ";"), ";;;;"), ";")
    it.Offset(, 1).Resize(, UBound(ar) + 1) = ar
 Next
End Sub

 

[Jyggalag]

Try this:

Sub SplitEmails()

    Dim lr As Long
    Dim r As Long
    Dim arr() As String
    Dim col(2) As String
    Dim i As Long
   
    Application.ScreenUpdating = False
   
'   Pre-populate column reference array
    col(0) = "K"
    col(1) = "O"
    col(2) = "S"
   
'   Find last row in column J with data
    lr = Cells(Rows.Count, "J").End(xlUp).Row
   
'   Loop through all rows starting at row 2
    For r = 2 To lr
'       Build array of email addresses
        arr = Split(Cells(r, "J"), ";")
'       Loop through and populate columns
        For i = LBound(arr) To UBound(arr)
            Cells(r, col(i)) = arr(i)
        Next i
    Next r
   
    Application.ScreenUpdating = True
   
End Sub

Both of your codes are amazing!!

Thank you so much guys! I designed to assign this code to a macro for now and it works perfectly. Much appreciated, you've really made my day :D

 

[Joe4]

You are welcome.
Glad we were able to help!