# Separate emails into bits through macro and text to columns

#### Jyggalag

##### Active Member
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.

### Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a \$25,000 loan, 5% annual interest, 60 month loan.
Try this:
VBA Code:
``````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``````

One other variant

VBA Code:
``````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``````

Try this:
VBA Code:
``````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

You are welcome.
Glad we were able to help!

Replies
2
Views
155
Replies
14
Views
2K
Replies
2
Views
2K
Replies
4
Views
2K
Replies
3
Views
2K

1,207,205
Messages
6,077,045
Members
446,252
Latest member
vettaforza

### 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.

### Which adblocker are you using?

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

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