Multi-line excel cells into rows

Pls find dummy sheet and desired output sheet enclosed.

This should work

Sub SplitCellsIntoRows()
    Const col_LONGNAME As String = "A"
    Const col_APPREVIATION As String = "B"
    Const col_COLOUR As String = "C"
    
    Dim arrName() As String
    Dim arrAbbr() As String
    Dim arrColour() As String
    
    Dim r As Long
    Dim m As Long
    Dim i As Long
    Dim n As Long
    
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    m = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For r = m To 2 Step -1
        With ws
            arrName = Split(.Range(col_LONGNAME & r), Chr(10))
            arrAbbr = Split(.Range(col_APPREVIATION & r), Chr(10))
            arrColour = Split(.Range(col_COLOUR & r), Chr(10))
        End With
        n = Application.Max(UBound(arrName), UBound(arrAbbr), UBound(arrColour))
        
        ReDim Preserve arrName(n)
        ReDim Preserve arrAbbr(n)
        ReDim Preserve arrColour(n)
        For i = n To 1 Step -1
            With ws
                .Range(col_LONGNAME & (r + 1)).EntireRow.Insert
                .Range(col_LONGNAME & (r + 1)) = Trim(arrName(i))
                .Range(col_APPREVIATION & (r + 1)) = Trim(arrAbbr(i))
                .Range(col_COLOUR & (r + 1)) = Trim(arrColour(i))
            End With
        Next i
        With ws
            .Range(col_LONGNAME & r) = Trim(arrName(0))
            .Range(col_APPREVIATION & r) = Trim(arrAbbr(0))
            .Range(col_COLOUR & r) = Trim(arrColour(0))
        End With
    Next r
    
    For r = 2 To ws.Cells(Rows.Count, "C").End(xlUp).Row
        With ws
            If .Cells(r, "D") = "" Then
                .Cells(r, "D") = .Cells(r - 1, "D")
                .Cells(r, "E") = .Cells(r - 1, "E")
            End If
        End With
    Next r
End Sub

try

Sub test()
    Dim a, b(), i As Long, ii As Long, iii As Long, n As Long, x
    With Range("a1").CurrentRegion
        a = .Value
        ReDim b(1 To Rows.Count, 1 To 5)
        On Error Resume Next
        For i = 1 To UBound(a, 1)
            x = Split(a(i, 1), vbLf)
            For ii = 0 To UBound(x)
                n = n + 1
                For iii = 1 To 3
                    b(n, iii) = Split(a(i, iii), vbLf)(ii)
                Next
                For iii = 4 To UBound(a, 2)
                    b(n, iii) = a(i, iii)
                Next
            Next
        Next
        On Error GoTo 0
        .Offset(.Rows.Count + 2).Resize(n).Value = b
    End With
End Sub

jindon & mike7952,

Thank you for your help. I'm still very beginner with Macros. How do I have to adjust the equation/macro if I want to increase the number of rows and columns in my excel sheet. In my actual data set my data expands up to column CL (which of columns A to F have multi-line data) and up to row 11550, number of lines within one column being max 54.

I just try to understand what are the lines which I have to modify.

Can you upload you workbook?

Pls find extract of it enclosed. Unfortunately the whole file is too big to be uploaded.

try this

Sub test()
    Dim a, b(), i As Long, ii As Long, iii As Long, n As Long, x
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("result").Delete
    Sheets.Add(after:=Sheets(1)).Name = "result"
    
    With Sheets("Activesheet")
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Resize(, 91).Value
    End With
    ReDim b(1 To Rows.Count, 1 To UBound(a, 2))
    On Error Resume Next
    For i = 1 To UBound(a, 1)
        x = Split(a(i, 1), vbLf)
        For ii = 0 To UBound(x)
            n = n + 1
            For iii = 1 To 6
                b(n, iii) = Split(a(i, iii), vbLf)(ii)
            Next
            For iii = 7 To UBound(a, 2)
                b(n, iii) = a(i, iii)
            Next
        Next
    Next
    On Error GoTo 0
    Sheets("result").Cells(1).Resize(n, UBound(b, 2)).Value = b
End Sub

Thnx Jindon,

It works perfectly with the extract file but gives error when I try to run it with the whole data. Any idea what could be the reason. Error message / bug seems to be in the last row of the code " Sheets("result").Cells(1).Resize(n, UBound(b, 2)).Value = b"

---------- Post added at 10:38 AM ---------- Previous post was at 10:35 AM ----------

'Run-time error '9': Subscript out of range' is the error code.

Originally Posted by walimos

'Run-time error '9': Subscript out of range' is the error code.

It seems the code doesn't find the sheet named "result"...

Do you actually see the added sheet named result?

Yes I do. But nothing in it.

Do you have actually have sheet named "ActiveSheet"?

No I didn't have it. It seemed to solve the problem and works like a champ now. Thank you for your help jindon. You saved my day.

OK, no problem.