Split Cell in Excel 2007

Question

I have a huge excel file (2 MB) that contains multiple lines of data in a cell. Please see screenshot for details. I am having little luck trying to split them into lines of their own. I am using this VB script that I got from another post here on Stackoverflow. When I run this on individual columns, the application hangs. Is there a way to split the cells in each column into its own row?

Sub JustDoIt()
    'working for active sheet
    'copy to the end of sheets collection
    ActiveSheet.Copy after:=Sheets(Sheets.Count)
    Dim tmpArr As Variant
    Dim Cell As Range
    For Each Cell In Range("C1", Range("C2").End(xlDown))
        If InStr(1, Cell, Chr(10)) <> 0 Then
            tmpArr = Split(Cell, Chr(10))

            Cell.EntireRow.Copy
            Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
                EntireRow.Insert xlShiftDown

            Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
        End If
    Next
    Application.CutCopyMode = False
End Sub

Any help is highly appreciated and thank you in advance.

Answer 1

If I understand your question correctly, you could solve this by doing the following:

1. Unmerge the merged cells.

2. Let's say, for example's sake, that the column you're trying to modify is column A. Insert a new column to the right of column A. Then use the following formula:

   =IF(A2<>"",A2,B1)

Applying this formula downward should give you your desired format.

Answer 2

The macro seems viable programmatically. However, it might be crashing because there's too much data on your end. I think the best way to do this is to create a subroutine from the above, and call it one by one on your cells. See my attempt below.

Code:

Sub SplitLine(SrcRng As Range, TargetRng As Range)

    StrToSplit = SrcRng.Value
    If InStr(1, StrToSplit, Chr(10)) Then
        SplitArr = Split(StrToSplit, Chr(10))
        With TargetRng
            .Resize(UBound(SplitArr) + 1, 1).Value = Application.Transpose(SplitArr)
        End With
    End If

End Sub

Given the following data:

I will call the above code like so:

Sub Test()

    Dim SourceSh As Worksheet, TargetSh As Worksheet
    Dim SourceRng As Range, CellRng As Range
    Dim TargetRng As Range

    With ThisWorkbook
        Set SourceSh = .Sheets("Sheet3")
        Set TargetSh = .Sheets("Sheet4")
    End With

    Set SourceRng = SourceSh.Range("A1:D1")
    Set TargetRng = TargetSh.Range("A1")

    Application.ScreenUpdating = False
    For Each CellRng In SourceRng
        SplitLine CellRng, TargetRng
        Set TargetRng = TargetRng.Offset(0, 1)
    Next
    Application.ScreenUpdating = True

End Sub

Result is as follows:

Let us know if this helps.