# Split Cell into Four Columns, Based on Two Criteria

Hello Experts,

I would like to request your help in writing a vba code that will split all cells in a selected range, based on the following criteria (Please refer to Excel attachment for all column references):

## 1.

Find the last instance of the character ":" (colon) for each cell in column B and split into two columns. (If no colon found, copy and paste full cell string into column C

## 2.

Split Column D (text to column) by using the character "-" (hyphen) as the delimiter
Ultimately the columns that will be useful for my purposes will be D, and F, which are the account number and account description.  Down the road I will need to figure out how to delete column E, since I won't need, but I can try to figure that part out later on.

Book1.xlsx
###### Who is Participating?

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Commented:
Quick question are you open to do this by formulas or you want to do this by macro only???

Saurabh...
AccountantAuthor Commented:
I would prefer to do by macro, since I'd like to add to my personal ribbon list of macros.

Thanks Saurabh
Commented:
Use this code...

Sub getvalues()
Dim cell As Range, rng As Range
Dim lrow As Long, k As Long

lrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

Set rng = Range("B2:B" & lrow)

For Each cell In rng

If Len(cell.Value) - Len(Replace(cell.Value, "-", "")) > 1 Then
cell.Offset(0, 1).Value = Left(cell.Value, InStrRev(cell.Value, ":"))
cell.Offset(0, 2).Value = Mid(cell.Value, InStrRev(cell.Value, ":", -1, vbTextCompare) + 1, InStrRev(cell.Value, "-", -1, vbTextCompare) - InStrRev(cell.Value, ":", -1, vbTextCompare) - 1)
cell.Offset(0, 3).Value = "-"
cell.Offset(0, 4).Value = Right(cell.Value, Len(cell.Value) - InStrRev(cell.Value, "-", -1, vbTextCompare) - 1)
Else
cell.Offset(0, 1).Value = cell.Value
cell.Offset(0, 2).Value = Left(cell.Value, InStr(1, cell.Value, "-", vbTextCompare) - 1)
cell.Offset(0, 3).Value = "-"
cell.Offset(0, 4).Value = Right(cell.Value, Len(cell.Value) - InStrRev(cell.Value, "-", -1, vbTextCompare))

End If

Next cell

End Sub

Saurabh...
AccountantAuthor Commented:
Hello Saurabh,

This works like a charm!

I have an additional question, and this is completely my fault for not providing the entire range of cells to be splitted, but how can we get around the following:

16000- Property, Plant & Equip:16100- Computing and Commun.:16150- Telephone System - SD

If you'll notice, in this account description, there is an additional "-" (hyphen), after the last occurrence of the ":" delimiter.  So currently, the code splits this account description as follows:

If you'd like me to create a second question to award additional points, by all means, please let me know.
Commented:
Try using this...

Sub getvalues()
Dim cell As Range, rng As Range
Dim lrow As Long, k As Long

lrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

Set rng = Range("B2:B" & lrow)

For Each cell In rng

If Len(cell.Value) - Len(Replace(cell.Value, "-", "")) > 1 Then
cell.Offset(0, 1).Value = Left(cell.Value, InStrRev(cell.Value, ":"))
cell.Offset(0, 2).Value = Mid(cell.Value, InStrRev(cell.Value, ":", -1, vbTextCompare) + 1, 5)
cell.Offset(0, 3).Value = "-"
cell.Offset(0, 4).Value = Right(cell.Value, Len(cell.Value) - InStrRev(cell.Value, ":", -1, vbTextCompare) - 7)
Else
cell.Offset(0, 1).Value = cell.Value
cell.Offset(0, 2).Value = Left(cell.Value, InStr(1, cell.Value, "-", vbTextCompare) - 1)
cell.Offset(0, 3).Value = "-"
cell.Offset(0, 4).Value = Right(cell.Value, Len(cell.Value) - InStrRev(cell.Value, "-", -1, vbTextCompare))

End If

Next cell

End Sub

Saurabh...
Commented:
Also have assumed in the above code that your characters post : will be 5 digits..please let me know if thats not the case...as i made further dyanmic irrespective what the length is..

Sub getvalues()
Dim cell As Range, rng As Range
Dim lrow As Long, k As Long

lrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

Set rng = Range("B2:B" & lrow)

For Each cell In rng

If Len(cell.Value) - Len(Replace(cell.Value, "-", "")) > 1 Then
cell.Offset(0, 1).Value = Left(cell.Value, InStrRev(cell.Value, ":"))
cell.Offset(0, 2).Value = Mid(cell.Value, InStrRev(cell.Value, ":", -1, vbTextCompare) + 1, InStr(InStrRev(cell.Value, ":", -1, vbTextCompare) + 1, cell.Value, "-", vbTextCompare) - InStrRev(cell.Value, ":", -1, vbTextCompare) - 1)
cell.Offset(0, 3).Value = "-"
cell.Offset(0, 4).Value = Right(cell.Value, Len(cell.Value) - InStr(InStrRev(cell.Value, ":", -1, vbTextCompare) + 1, cell.Value, "-", vbTextCompare) - 1)
Else
cell.Offset(0, 1).Value = cell.Value
cell.Offset(0, 2).Value = Left(cell.Value, InStr(1, cell.Value, "-", vbTextCompare) - 1)
cell.Offset(0, 3).Value = "-"
cell.Offset(0, 4).Value = Right(cell.Value, Len(cell.Value) - InStrRev(cell.Value, "-", -1, vbTextCompare))

End If

Next cell

End Sub

Experts Exchange Solution brought to you by

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

AccountantAuthor Commented:
Hello Saurabh,

This definitely works better.  One last question, and if it's too much to ask, then I could definitely work with this solution you've provided.

Would it be possible to leave just the account number in the highlighted cell?

Everything else, works perfectly.

Thank you
Commented:
I have revised the codes which i gave to you..run them and you will find only account number in them provided you have ":" in your dataset..you can run both of them as i made some changes later on to make them more dynamic...
AccountantAuthor Commented:
Thank you very much Saurabh, this works perfectly!!!
Commented:
Yw...Happy to help... :-)
###### It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.