Text to Row

[Brawnystaff]

I am using the code below to convert text in selected cells in one row to other rows based on a specified delimiter (e.g. vbLF). It works fine for selected cells in a single row, but wondering what I need to do to have it work for selected cells on multiple rows? Thanks.

Sub Split2Rows()
'Split data in a cell based on inputted delimiter
    Dim arr As Variant
    Dim c As Range, Rng As Range
    Dim j As Long ' variable to iterate over the arr
    Dim RowN As Long ' number of rows to add
    Dim DCount As Long ' Delim count for active cell
    Dim Delim As String  'delimiter to split
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Delim = InputBox("Enter Delimiter to Split" & vbLf & "or Ok for Carriage Return", , vbLf)
    DCount = Len(ActiveCell) - Len(Replace(ActiveCell, Delim, ""))
    RowN = InputBox("Enter number of rows to add", , DCount)
    Set Rng = Selection
    If RowN = 0 Then GoTo Skip
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(RowN, 0)).Select
        Selection.EntireRow.Insert
Skip:

    ' iterating over all cells in Rng

    
        For Each c In Rng

        ' split function splits each cells content to an array
         arr = Split(c, Delim)  'split on inputted delim

        ' iterating over the array of split strings
        For j = LBound(arr) To UBound(arr)

            ' assigning the separated values to rows
             If c.Offset(RowN, 0).Value <> vbNullString Then Exit Sub
             c.Offset(j, 0) = arr(j)
        Next j
    Next c
    Selection.Rows.AutoFit
    Rng.Rows.AutoFit

     Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

[Bernie Deitrick]

For cells in a single column:

Sub Split2Rows()
    'Split data in a cell based on delimiter
    Dim arr As Variant
    Dim Rng As Range
    Dim lRow As Long
    Dim j As Long ' variable to iterate over the arr
    Dim Delim As String  'delimiter to split
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    
    Delim = vbLf
    
    Set Rng = Selection
    
    For lRow = Cells(Rows.Count, Rng.Column).End(xlUp).Row To Rng.Cells(1).Row Step -1
      
        ' split function splits each cells content to an array
        arr = Split(Cells(lRow, Rng.Column), Delim)  'split on inputted delim
        ' iterating over the array of split strings
        Cells(lRow, Rng.Column).Value = arr(0)
        For j = 1 To UBound(arr)
            ' assigning the separated values to rows
            If Cells(lRow, Rng.Column).Offset(j, 0).Value <> "" Then
                Cells(lRow, Rng.Column).Offset(j, 0).EntireRow.Insert
            End If
            Cells(lRow, Rng.Column).Offset(j, 0) = arr(j)
        Next j
    Next lRow
    Selection.Rows.AutoFit
    Rng.CurrentRegion.Rows.AutoFit
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

[Brawnystaff]

Thanks Bernie.. That will work..