Split one column into multiple columns

Question

I was wondering if anybody can kindly advise how to split a string with comma-separated values into multiple columns. I have been trying to figure this out but have been having a hard time finding a good solution. (also checked online, seems several that comes close but not necessarily fit what I exactly need)

Let's say I have a worksheet, call it "example", for instance, and in the worksheet has the following strings under multiple rows but all in column "A".

20120112,aaa,bbb,ccc,3432 
20120113,aaa,bbb,ccc
20120113,ddd,bb,ccc,ddd,eee,fff,ggg,hhhh 
20120132,aaa,bbb,ccc
20120112,aaa,bbb,ccc 
20120112,xxx,bbb,ggg,ggg,333
20120112,aaa,bbb,ccc 
20120112,abbd,bbb,ccc

How can I create a macro that will split the above into multiple columns.

Just several points

(1) I should be able to specify the worksheet name ex: something like

worksheets("example").range(A,A) '

(2) The number of columns and rows are not fixed, and so I do not know how many comma-separated values and how many rows there would be before I run the vba script.

Answer 1

• You could use InputBox() function and get the name of the sheet with data which shlould be splitted.
• Then copy the data into variant array, split them and create new array of splitted values.
• Finally assign the array of splitted values back to excel range. HTH

(Notice that the source data are modified directly so finally it is separated into columns and original un-splitted state is lost. But it is possible to modify the code so the original data won't be overwritten.)

Option Explicit

Private Const sourceColumnName As String = "A"
Private Const delimiter As String = ","

Public Sub Splitter()

    ' splits one column into multiple columns

    Dim sourceSheetName As String
    Dim sourceSheet As Worksheet
    Dim lastRow As Long
    Dim uboundMax As Integer
    Dim result

    On Error GoTo SplitterErr

    sourceSheetName = VBA.InputBox("Enter name of the worksheet:")

    If sourceSheetName = "" Then _
        Exit Sub

    Set sourceSheet = Worksheets(sourceSheetName)

    With sourceSheet
        lastRow = .Range(sourceColumnName & .rows.Count).End(xlUp).row
        result = SplittedValues(data:=.Range(.Cells(1, sourceColumnName), _
                                             .Cells(lastRow, sourceColumnName)), _
                                partsMaxLenght:=uboundMax)

        If Not IsEmpty(result) Then
            .Range(.Cells(1, sourceColumnName), _
                   .Cells(lastRow, uboundMax)).value = result
        End If
    End With

SplitterErr:
    If Err.Number <> 0 Then _
        MsgBox Err.Description, vbCritical
End Sub

Private Function SplittedValues( _
    data As Range, _
    ByRef partsMaxLenght As Integer) As Variant

    Dim r As Integer
    Dim parts As Variant
    Dim values As Variant
    Dim value As Variant
    Dim splitted As Variant

    If Not IsArray(data) Then
        ' data consists of one cell only
        ReDim values(1 To 1, 1 To 1)
        values(1, 1) = data.value
    Else
        values = data.value
    End If

    ReDim splitted(LBound(values) To UBound(values))

    For r = LBound(values) To UBound(values)

        value = values(r, 1)
        If IsEmpty(value) Then
            GoTo continue
        End If

        ' Split always returns zero based array so parts is zero based array
        parts = VBA.Split(value, delimiter)
        splitted(r) = parts

        If UBound(parts) + 1 > partsMaxLenght Then
            partsMaxLenght = UBound(parts) + 1
        End If

continue:
    Next r

    If partsMaxLenght = 0 Then
        Exit Function
    End If

    Dim matrix As Variant
    Dim c As Integer
    ReDim matrix(LBound(splitted) To UBound(splitted), _
                 LBound(splitted) To partsMaxLenght)

    For r = LBound(splitted) To UBound(splitted)
        parts = splitted(r)
        For c = 0 To UBound(parts)
            matrix(r, c + 1) = parts(c)
        Next c
    Next r

    SplittedValues = matrix
End Function

Answer 2

If you don't need to work on this task later again, here is a manual way as workaround:

1. Use a text editor (Notepad++) to replace "," to "tab".
2. Copy the content and paste into an empty Excel sheet.

Or you can try Excel import the data from file ("," as separator).

In case you need an automatic script, try this: 1) Press Ctrl+F11 to open VBA editor, insert a Module. 2) click the Module, add code inside as below.

Option Explicit

Public Function LastRowWithData(ByRef sht As Excel.Worksheet, Optional colName As String = "A") As Long
    LastRowWithData = sht.Range(colName & sht.Rows.Count).End(xlUp).Row
End Function

Sub SplitToColumns(ByRef sColNames As String, ByRef strSeparator As String, ByRef rngDest As Excel.Range)
    Dim arrColNames As Variant, i As Long

    arrColNames = Split(sColNames, strSeparator)
    For i = LBound(arrColNames) To UBound(arrColNames)
        rngDest.Offset(0, i).Value = arrColNames(i)
    Next i
End Sub

Sub PerformTheSplit()
    Dim totalRows As Long, i As Long, sColNames As String

    totalRows = LastRowWithData(Sheet1, "A")
    For i = 1 To totalRows
        sColNames = Sheet1.Range("A" & i).Value
        Call SplitToColumns(sColNames, ",", Sheet2.Range("A" & i))
    Next i
End Sub

3) Suppose you have the column name in Sheet1:

Press "Alt+F8" to run macro "PerformTheSplit", you will see result in Sheet2:

Answer 3

I would just use the Text-to-Columns wizard, with VBA routines to allow you to select the sheet and range to process, as you request above.

The Input boxes are used to obtain the sheet and range to process, and will default to the Active Sheet and Selection. This could certainly be modified in a variety of ways.

The built-in text to columns feature is then called, and, although you did not so specify, ti seems your first column represents a date in YMD format, so I added that as an option -- it should be obvious how to remove or change it if required.

Let me know how it works for you:

---

Option Explicit
Sub TTC_SelectWS_SelectR()
    Dim WS As Worksheet, R As Range
    Dim sMB As String
    Dim v

On Error Resume Next
Set WS = Worksheets(Application.InputBox(Prompt:="Enter Worksheet Name: ", _
        Title:="Select Worksheet", _
        Default:=ActiveSheet.Name, _
        Type:=2))
    If Err.Number <> 0 Then
        sMB = MsgBox("Invalid Worksheet Name", vbRetryCancel)
        If sMB = vbRetry Then TTC_SelectWS_SelectR
        Exit Sub
    End If
On Error GoTo 0

    Set R = (Application.InputBox(Prompt:="Select Range to Process: ", _
                Title:="Select Range", _
                Default:=Selection.Address, _
                Type:=8))

    Set R = WS.Range(R.Address)

R.TextToColumns DataType:=xlDelimited, textqualifier:=xlTextQualifierDoubleQuote, _
        consecutivedelimiter:=False, Tab:=False, semicolon:=False, comma:=True, Space:=False, _
        other:=False, fieldinfo:=Array(Array(1, xlYMDFormat))

End Sub

---