Split delimited data in one cell to multiple rows using macro & apply to whole column

[dfolzenlogen]

Hi All,

I routinely have a column of data which is quite lengthy with each cell in that data containing numerous names separated by a ";". I want to split those names to individual rows to a 2nd column. I found some code online which accomplishes the split portion. See below. What I would like to do is create a macro that runs through the entire column, splits the names in each cell and appends them to the data in a 2nd column rather than run the macro on a cell-by-cell basis and point to the empty cell where I want the split names to reside. Any suggestions.

Sub SplitAll()
    Dim xRg As Range
    Dim xRg1 As Range
    Dim xCell As Range
    Dim I As Long
    Dim xAddress As String
    Dim xUpdate As Boolean
    Dim xRet As Variant
    On Error Resume Next
    xAddress = Application.ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select a range", "Kutools for Excel", xAddress, , , , , 8)
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub
        If xRg.Columns.Count > 1 Then
            MsgBox "You can't select multiple columns", , "Kutools for Excel"
            Exit Sub
            End If
            Set xRg1 = Application.InputBox("Split to (single cell):", "Kutools for Excel", , , , , , 8)
            Set xRg1 = xRg1.Range("A1")
            If xRg1 Is Nothing Then Exit Sub
                xUpdate = Application.ScreenUpdating
                Application.ScreenUpdating = False
                For Each xCell In xRg
                    xRet = Split(xCell.Value, "; ")
                    xRg1.Worksheet.Range(xRg1.Offset(I, 0), xRg1.Offset(I + UBound(xRet, 1), 0)) = Application.WorksheetFunction.Transpose(xRet)
                    I = I + UBound(xRet, 1) + 1
                Next
                Application.ScreenUpdating = xUpdate
            End Sub

 

[mumps]

If I interpreted correctly what you want to do, this macro should do it. It assumes your data is in column A starting at row 2 and the split data will be placed in column. Change the columns in the macro to suit your needs.

Sub SplitData()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim splitRng As Variant
    Dim i As Long
    Dim bottomA As Long
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    For Each rng In Range("A2:A" & bottomA)
        splitRng = Split(rng, ";")
        For i = LBound(splitRng) To UBound(splitRng)
            Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = splitRng(i)
        Next i
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

If I interpreted correctly what you want to do, this macro should do it. It assumes your data is in column A starting at row 2 and the split data will be placed in column. Change the columns in the macro to suit your needs.

Sub SplitData()
    Application.ScreenUpdating = False
    Dim rng As Range
    Dim splitRng As Variant
    Dim i As Long
    Dim bottomA As Long
    bottomA = Range("A" & Rows.Count).End(xlUp).Row
    For Each rng In Range("A2:A" & bottomA)
        splitRng = Split(rng, ";")
        For i = LBound(splitRng) To UBound(splitRng)
            Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = splitRng(i)
        Next i
    Next rng
    Application.ScreenUpdating = True
End Sub

If your interpretation of what the OP is correct, and assuming that when the OP said that he had a "column of data which is quite lengthy" he meant less than about 65000 rows, then you can write your SplitData macro without using any loops...

Sub SplitData()
  Dim Combined As Variant
  Combined = Split(Join(Application.Transpose(Range("A2", Cells(Rows.Count, "A").End(xlUp))), ";"), ";")
  Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(UBound(Combined) + 1) = Application.Transpose(Combined)
End Sub

 

[dfolzenlogen]

Thanks to both Mumps and Rick!! Both methods worked beautifully. I appreciate you!!

D

 

[mumps]

Glad to help.