Separate each word after line breaks into new rows-CodePudding

My loop seems to create infinite rows and is bugging

For Each Cell In Workbooks(newBook).Sheets(1).Range("A1:A" & lRow)
    Checker = Cell.Value
    For Counter = 1 To Len(Checker)
        If Mid(Checker, Counter, 1) = vbLf Then
            holder = Right(Mid(Checker, Counter, Len(Checker)), Len(Checker))
            Workbooks(newBook).Sheets(1).Range(Cell.Address).EntireRow.Insert
        End If
    Next
Next Cell

CodePudding user response：

Use a reverse loop. For i = lRow to 1 Step -1. Also to separate word, you can use SPLIT().

Is this what you are trying?

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long
    Dim i As Long, j As Long
    Dim Ar As Variant
    
    '~~> Change this to the relevant worksheet
    Set ws = Sheet2
    
    With ws
        '~~> Find last row in Column A
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        '~~> Reverse Loop in Column A
        For i = lRow To 1 Step -1
            '~~> Check if cell has vbLf
            If InStr(1, .Cells(i, 1).Value, vbLf) Then
                '~~> Split cell contents
                Ar = Split(.Cells(i, 1).Value, vbLf)
                
                '~~> Loop through the array from 2nd position
                For j = LBound(Ar)   1 To UBound(Ar)
                    .Rows(i   1).Insert
                    .Cells(i   1, 1).Value = Ar(j)
                Next j
                
                '~~> Replace cells contents with content from array from 1st position
                .Cells(i, 1).Value = Ar(LBound(Ar))
            End If
        Next i
    End With
End Sub

BEFORE

AFTER

CodePudding user response：

This is my solution, works with 2 dimensional ranges as well and it works on Selection, so select the range with the cells you want to split and run the code.

Sub splitByNewLine()
    Dim pasteCell As Range, rowCumulationTotal As Integer
    rowCumulationTotal = 0
    Dim arr() As Variant
    arr = Selection
    Selection.Clear
    
    For i = 1 To UBound(arr)
        Dim rowCumulationCurrent As Integer, maxElemsOnRow As Integer
        rowCumulationCurrent = 0
        maxElemsOnRow = 0
        For j = 1 To UBound(arr, 2)
            Dim elems() As String, elemCount As Integer
            elems = Split(arr(i, j), vbLf)
            elemCount = UBound(elems)
            For k = 0 To elemCount
                Cells(Selection.Row   i   rowCumulationTotal   k - 1, Selection.Column   j - 1) = elems(k)
                If maxElemsOnRow < k Then
                    rowCumulationCurrent = rowCumulationCurrent   1
                    maxElemsOnRow = k
                End If
            Next k
        Next j
        rowCumulationTotal = rowCumulationTotal   rowCumulationCurrent
    Next i
    Exit Sub
End Sub

Input:

Output: