Split Cell into multiple column via VBA

[sn3574]

Hi,
New to VBA and hope someone can help me here.
I have a cell with "::" delimiter like this FEB2020::MAR2020:APR2020
I am trying to split it to 3 different columns


Please see attached for example

I know it can be done via text to column but I need it in a sciprt with other tasks.

[paulked]

Hi and welcome to the forum.

Try this:



Sub test()
Dim ar, rw As Long, rng As Range
rw = 2
Do Until Cells(rw, 1) = ""
ar = Split(Cells(rw, 2), "::")
Set rng = Cells(rw, 3).Resize(1, UBound(ar) + 1)
rng.Value2 = ar
rw = rw + 1
Loop
End Sub


Or, if you have hundreds of rows, this is faster:



Sub test2()
Dim ar, ar1, ar2, i As Long, j As Long
ar = Range(Range("B2"), Range("B2").End(xlDown))
ReDim ar1(2, 0)
For i = 1 To UBound(ar)
For j = 0 To 2
ar2 = Split(ar(i, 1), "::")
ar1(j, i - 1) = ar2(j)
Next
ReDim Preserve ar1(2, i)
Next
Range("C2:E" & i) = Application.Transpose(ar1)
End Sub

[sn3574]

Thank you so much for such a quick reply - I like the 2nd code which is exactly what I was needed.

Hi and welcome to the forum.

Try this:



Sub test()
Dim ar, rw As Long, rng As Range
rw = 2
Do Until Cells(rw, 1) = ""
ar = Split(Cells(rw, 2), "::")
Set rng = Cells(rw, 3).Resize(1, UBound(ar) + 1)
rng.Value2 = ar
rw = rw + 1
Loop
End Sub


Or, if you have hundreds of rows, this is faster:



Sub test2()
Dim ar, ar1, ar2, i As Long, j As Long
ar = Range(Range("B2"), Range("B2").End(xlDown))
ReDim ar1(2, 0)
For i = 1 To UBound(ar)
For j = 0 To 2
ar2 = Split(ar(i, 1), "::")
ar1(j, i - 1) = ar2(j)
Next
ReDim Preserve ar1(2, i)
Next
Range("C2:E" & i) = Application.Transpose(ar1)
End Sub

[snb]

or


Sub M_snb()
Columns(1).Replace "::", ";"
Columns(1).TextToColumns , , , , 0, -1, 0, 0
End Sub

[Tom Jones]

or


Sub M_snb()
Columns(1).Replace "::", ";"
Columns(1).TextToColumns , , , , 0, -1, 0, 0
End Sub

@snb,

OP want:


I have a cell with "::" delimiter like this FEB2020::MAR2020:APR2020
I am trying to split it to 3 different columns




Try this:



Sub splitText()
Range("B2:B4").TextToColumns Range("C2"), 1, , , , , 1
End Sub

[paulked]

I've never had occation to use TextToColumns, great thing! It's also fast!

[sn3574]

Thank you so much for such a quick reply - I like the 2nd code which is exactly what I was needed.
Just one comment for this part : "For j = 0 To 2" , the code will not work if in the cell with the "::" you have empty cell or only 1 separator.

[paulked]

Correct.

[paulked]

Try this, it takes care of spaces, single colons, semicolons and blank lines



Sub test2()
Dim ar, ar1, ar2, i As Long, j As Long, str As String
ar = Range(Range("B2"), Range("B2").End(xlDown))
ReDim ar1(2, 0)
For i = 1 To UBound(ar)
For j = 0 To 2
str = Replace(ar(i, 1), " ", ";")
str = Replace(str, "::", ";")
str = Replace(str, ":", ";")
ar2 = Split(str, ";")
If str <> "" Then
ar1(j, i - 1) = ar2(j)
Else
ar1(j, i - 1) = ""
End If
Next
ReDim Preserve ar1(2, i)
Next
Range("C2:E" & i) = Application.Transpose(ar1)
End Sub