在Excel 2007中拆分单元格

Question

我有一个巨大的excel文件（2 MB），其中包含一个单元格中的多行数据。请查看截图了解详情。我试图将它们分成他们自己的线条，但我没有运气。我正在使用这个VB脚本，我从Stackoverflow上的另一篇文章获得。当我在各个列上运行它时，应用程序挂起。有没有办法将每列中的单元格拆分成自己的行？

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

非常感谢任何帮助，并提前感谢您。

Answer 1

如果我理解你的问题，你可以通过以下方式解决这个问题：

1. 取消合并合并的单元格。

2. 例如，假设您要修改的列是A列。在A列的右侧插入一个新列。然后使用以下公式：

   = IF（A2＆LT;＆gt; “中”，A2，B1）

向下应用此公式可以为您提供所需的格式。

Answer 2

该宏似乎可行编程。但是，它可能会崩溃，因为您的数据太多了。我认为最好的方法是从上面创建一个子程序，并在你的单元格上逐个调用它。请参阅下面的我的尝试。

<强>代码：

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

鉴于以下数据：

我会像上面这样调用上面的代码：

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

结果如下：

如果有帮助，请告诉我们。