Split multilines by carriage return into rows

[YasserKhalil]

Hello everyone
I have table of data and each cell in the range has multiple lines (by carriage return)
I need to have each line and related data in the same line to be in one row
There is a problem because the range has merged cells ..
The output would start in B7 and keep the merged cells

Note: I forgot column D but it is within the range too. Sorry

 

[Ashhu]

Hello Yasser,
If you are asking , how to copy data from merged cell to individual cells then

Go to merged cell and press F2 ------> Select and Copy---->Paste in required cell.
Sad part is we cannot do all merge cell copy and paste in one go,

 

[YasserKhalil]

Thanks a lot Mr. Ashhu fro quick reply
It is not a case of copying from merged cells
I need to output data .. each data to be in one row ..

 

[Asheesh]

Ashuu, Can you share the required output basis the data attached in the sample file

 

[Ashhu]

I am sorry, i thought you need way to copy data from merged cell, if you are looking for formula then ignore my suggestion in #2 reply.

 

[YasserKhalil]

May be copy whole original range paste it in B7 then split based on chr(10) the lines of each merged cell

 

[Chihiro]

@YasserKhalil
Does output have to be on same sheet?

Merged Cell = Evil

Here's sample code (I'm bit lazy and didn't make it completely dynamic), that replicates data in Sheet2 with split rows.

Sub Test()
Dim x, y
Dim i As Integer, j As Integer
Dim c As Range

ReDim y(0 To 7, 0 To 4)
j = 0
For Each c In Union(Sheet1.Range("B3:E3"), Sheet1.Range("H3"))
    x = Split(c, Chr(10))
    For i = LBound(x) To UBound(x)
        y(i, j) = x(i)
    Next
    j = j + 1
Next c

Sheet1.Range("B2:D2").Copy Sheet2.Range("B2")
Sheet2.Range("E2").Value = Sheet1.Range("E2").Value
Sheet2.Range("F2").Value = Sheet1.Range("H2").Value
Sheet2.Range("B3").Resize(8, 5).Value = y

End Sub

 

[YasserKhalil]

Mr. Chihiro you are HERO
Thanks a lot for this great and perfect code
You are wonderful
Best and Kind Regards

 

[jindon]

Sub test()
    Dim a, i As Long, ii As Long, x, rng As Range
    Dim myRows As Long, n As Long, txt As String
    Application.ScreenUpdating = False
    With Sheets("table 1").[b2].CurrentRegion
        Set rng = .Offset(.Rows.Count + 3).Cells(1)
        rng.CurrentRegion.Clear
        .Copy rng
    End With
    With rng.CurrentRegion
        a = .Value
        txt = Join(Application.Transpose(.Columns(1).Value), vbLf)
        myRows = Len(txt) - Len(Replace(txt, vbLf, "")): n = 2
        .Rows(2).Copy .Rows(3).Resize(myRows - 1)
        For i = 2 To UBound(a, 1)
            For ii = 1 To UBound(a, 2)
                If a(i, ii) <> "" Then
                    x = Split(a(i, ii), vbLf)
                    .Cells(n, ii).Resize(UBound(x) + 1).Value = _
                    Application.Transpose(x)
                End If
            Next
            n = n + UBound(Split(a(i, 1), vbLf)) + 1
        Next
        .Rows.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

 

[YasserKhalil]

Really fascinating Mr. Jindon
With your solutions I am astonished of this GENIUS MIND
Thank you very much for incredible help