VBA - Split string into individual cells

Question

I have a string compressed into one cell. I need to separate each part of the string into their own cell, while copying the data from the same row.

Here is my example data:

        A               |    B                  
Row1 ABC ABD ABE ABF    |  CODE1
Row2 BCA DBA EBA FBA    |  CODE2
Row3 TEA BEF            |  CODE3

The result would be:

 A     B
ABC  CODE1
ABD  CODE1
ABE  CODE1
ABF  CODE1
BCA  CODE2
DBA  CODE2
EBA  CODE2
FBA  CODE2
TEA  CODE3
BEF  CODE3

I have about 2000 rows and would literally take 30 years to use the text to column function for this. So I am trying to write a vba macro. I think I am making this harder than it needs to be. Any thoughts or pushes in the right direction would be appreciated. Thanks in advance for any help.

Answer 1

Here is the solution I devised with help from above. Thanks for the responses!

Sub Splt()
    Dim LR As Long, i As Long
    Dim X As Variant
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Columns("A").Insert
    For i = LR To 1 Step -1
        With Range("B" & i)
            If InStr(.Value, " ") = 0 Then
                .Offset(, -1).Value = .Value
            Else
                X = Split(.Value, " ")
                .Offset(1).Resize(UBound(X)).EntireRow.Insert
                .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value =            Application.Transpose(X)
            End If
        End With
    Next i
    Columns("B").Delete
    LR = Range("A" & Rows.Count).End(xlUp).Row
    With Range("B1:C" & LR)
        On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        On Error GoTo 0
        .Value = .Value
    End With
    Application.ScreenUpdating = True
    End Sub

Answer 2

Here is an approach using a User Defined Type, Collection and arrays. I've been using this lately and thought it might apply. It does make writing the code easier, once you get used to it.

The user defined type is set in a class module. I called the type "CodeData" and gave it two properties -- Code and Data

I assumed your data was in columns A & B starting with row 1; and I put the results on the same worksheet but in columns D & E. This can be easily changed, and put on a different worksheet if that's preferable.

First, enter the following code into a Class Module which you have renamed "CodeData"

Option Explicit
Private pData As String
Private pCode As String

Property Get Data() As String
    Data = pData
End Property
Property Let Data(Value As String)
    pData = Value
End Property

Property Get Code() As String
    Code = pCode
End Property
Property Let Code(Value As String)
    pCode = Value
End Property

Then put the following code into a Regular module:

Option Explicit
Sub ParseCodesAndData()
    Dim cCodeData As CodeData
    Dim colCodeData As Collection
    Dim vSrc As Variant, vRes() As Variant
    Dim V As Variant
    Dim rRes As Range
    Dim I As Long, J As Long

'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")

'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))

'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
    V = Split(vSrc(I, 1), " ")
    For J = 0 To UBound(V)
        Set cCodeData = New CodeData
        cCodeData.Code = Trim(vSrc(I, 2))
        cCodeData.Data = Trim(V(J))
    colCodeData.Add cCodeData
    Next J
Next I

'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
    Set cCodeData = colCodeData(I)
    vRes(I, 1) = cCodeData.Data
    vRes(I, 2) = cCodeData.Code
Next I

'Write array to worksheet
Application.ScreenUpdating = False

rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes

Application.ScreenUpdating = True

End Sub

Answer 3

Let me try as well using Dictionary :)

Sub Test()
    Dim r As Range, c As Range
    Dim ws As Worksheet
    Dim k, lrow As Long, i As Long

    Set ws = Sheet1 '~~> change to suit, everything else as is
    Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))

    With CreateObject("Scripting.Dictionary")
        For Each c In r
            If Not .Exists(c.Value) Then
                .Add c.Value, Split(Trim(c.Offset(0, -1).Value))
            End If
        Next
        ws.Range("A:B").ClearContents
        For Each k In .Keys
            lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            If lrow = 1 Then i = 0 Else i = 1
            ws.Range("A" & lrow).Offset(i, 0) _
                .Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
            ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
        Next
    End With
End Sub

Above code loads all items in Dictionary and then return it in the same Range. HTH.

Answer 4

Assuming your data is on the first sheet, this populates the second sheet with the formatted data. I also assume that the data is uniform, meaning there is the same type of data on every row until the data ends. I did not attempt the header line.

Public Sub FixIt()

    Dim fromSheet, toSheet As Excel.Worksheet

    Dim fromRow, toRow, k As Integer

    Dim code As String

    Set fromSheet = Me.Worksheets(1)
    Set toSheet = Me.Worksheets(2)

    ' Ignore first row
    fromRow = 2

    toRow = 1

    Dim outsideArr() As String
    Dim insideArr() As String

    Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""

        ' Split on the pipe
        outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")

        ' Split left of pipe, trimmed, on space
        insideArr = Split(Trim(outsideArr(0)), " ")

        ' Save the code
        code = Trim(outsideArr(UBound(outsideArr)))

        ' Skip first element of inside array
        For k = 1 To UBound(insideArr)
            toSheet.Cells(toRow, 1).Value = insideArr(k)
            toSheet.Cells(toRow, 2).Value = code
            toRow = toRow + 1

        Next k

        fromRow = fromRow + 1

    Loop


End Sub

Answer 5

I like iterating over cells for problems like this post.

        ' code resides on input sheet
        Sub ParseData()
            Dim wksOut As Worksheet
            Dim iRowOut As Integer
            Dim iRow As Integer
            Dim asData() As String
            Dim i As Integer
            Dim s As String

            Set wksOut = Worksheets("Sheet2")
            iRowOut = 1

            For iRow = 1 To UsedRange.Rows.Count
                asData = Split(Trim(Cells(iRow, 1)), " ")
                For i = 0 To UBound(asData)
                    s = Trim(asData(i))
                    If Len(s) > 0 Then
                        wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
                        wksOut.Cells(iRowOut, 2) = s
                        iRowOut = iRowOut + 1
                    End If
                Next i
            Next iRow

            MsgBox "done"
        End Sub

Answer 6

This will work, (but it's mighty inefficient unless you do it in an array... nevertheless for only 2000 rows, you won't even notice the lag)

Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
    SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function

Use it as

= SPLITTHIS("ABC EFG HIJ", " ", 2)

' The result will be ...

"EFG"

You will still need to put in a whole lot of extra error checking, etc. if you need to use it for a distributed application, as the users might put in values greater than the number of 'split elements' or get delimiters wrong, etc.