Split a single cell at line breaks-CodePudding

I have a spreadsheet that has data in a single cell separated by line breaks. I need to split the cell into separate rows so that I can remove some data and recombine. Like this:

Item	Status
285T1150-3	285T0680-1 1 Complete 285T1145-7//D 1 ATS-182 285T1146-1//D 1 Complete 363A4872P4 1 No Router

Convert to this:

Item	Status
285T1150-3	285T0680-1 1 Complete
285T1150-3	285T1145-7//D 1 ATS-182
285T1150-3	285T1146-1//D 1 Complete
285T1150-3	363A4872P4 1 No Router

This is the code I've been using:

        check_col = colArray(0)
        ColLastRow = Range(check_col & Rows.Count).End(xlUp).Row
        For Each Rng In Range(check_col & "1" & ":" & check_col & ColLastRow)
            If InStr(Rng.Value, vbLf) Then
                Rng.EntireRow.Copy
                Rng.EntireRow.Insert
                
                For i = 0 To UBound(colArray)
                    c = colArray(i)
                    
                    Set currentrng = Range(c & Rng.Row)
                    Set upperRng = currentrng.Offset(-1, 0)
                
                    upperRng.Value = Mid(currentrng.Value, 1, InStr(currentrng.Value, vbLf) - 1)
                    currentrng.Value = Mid(currentrng.Value, Len(upperRng.Value)   2, Len(currentrng.Value))
                Next i
            End If
        Next

Which works perfectly. It just takes a very long time. Sometimes upwards of 5-8 minutes. Is there a way I can streamline this so that it runs a little faster?

CodePudding user response：

I'd strongly recommend PowerQuery for the task at hand:

Imagine the following sample data;
Select data, then load it into PQ as per below GIF;
PQ will open, follow the steps as below GIF;
Close PQ and save changes. Result will look like:

CodePudding user response：

For this particular data transformation, Power Query seems to be (and is) much powerful/faster than VBA like

For ~1.4k rows, the query will take less than 2~3 seconds to refresh.

DEMO :

CodePudding user response：

Additional variant to posted already:

Sub foo()
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim x&, cl As Range, data As Range, ws As Worksheet, spStr, dKey
    Set ws = ActiveSheet
    
    Set data = ws.Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
    x = 0
    For Each cl In data
        For Each slpstr In Split(cl, Chr(10))
            If slpstr <> "" Then
                dic.Add x, ws.Cells(cl.Row, "A").Value & "|" & slpstr
                x = x   1
            End If
    Next slpstr, cl
    Set ws = Worksheets.Add: ws.Name = "Result"
    x = 1
    For Each dKey In dic
        ws.Cells(x, "A").Value = Split(dic(dKey), "|")(0)
        ws.Cells(x, "B").Value = Split(dic(dKey), "|")(1)
        x = x   1
    Next dKey
    ws.[A:B].Columns.AutoFit
End Sub

For ~1.4k rows will take less than 1 second (tested using 1 core i7-11800H).

demo: