excel - 在换行符处拆分单元格中的文本

Question

我正在处理一个包含 39 列数据的 Excel 电子表格。这些列之一，列 AJ，是一个描述字段，包含详细描述行项目的文本。单元格内的此文本有时超过一行，并且已通过按 (ALT+Enter) 开始新行。

我需要能够复制整个工作表并将其全部放在另一张工作表（现有工作表）中，但在 AJ 列中的每个新行都有一个新行，如下所示：

Column A     Column B     Column AJ
Electrical   Lighting     This is line one of the text
                          And in the same cell on a new line

这是所需的结果：

Column A     Column B     Column AJ
Electrical   Lighting     This is line one of the text
Electrical   Lighting     And in the same cell on a new line

我已经在论坛中搜索了类似的代码，但我无法将其用于我自己的目的。

更新：不确定为什么关闭，假设您可能想要一些代码的示例。我使用的是在互联网上找到的以下宏：

Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("AJ" & Rows.Count).End(xlUp).Row
Columns("AJ").Insert
For i = LR To 1 Step -1
    With Range("B" & i)
        If InStr(.Value, ",") = 0 Then
            .Offset(, -1).Value = .Value
        Else
            X = Split(.Value, ",")
            .Offset(1).Resize(UBound(X)).EntireRow.Insert
            .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
        End If
    End With
Next i
Columns("AK").Delete
LR = Range("AJ" & Rows.Count).End(xlUp).Row
With Range("AJ1:AK" & LR)
    On Error Resume Next
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    On Error GoTo 0
    .Value = .Value
End With
Application.ScreenUpdating = True
End Sub

但它不起作用，也许我没有正确调整它。

Answer 1

试试这个代码：

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("AJ1", Range("AJ2").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 2

用于=SUBSTITUTE(A1,CHAR(10),";")用“;”替换换行符 或其他一些轮廓符，以便文本到列可以使用可用的轮廓符之一为您解析它。

Answer 3

在我准确指定它应该定位的工作表之前，我在让 Kazimierz 代码工作之前遇到了一些问题。我的场景是多表排列，通过一些调查，我发现代码集中在第二个嵌套循环中的其他表上 - 原因不明。如果代码不适合您，我建议尝试以下代码段。

在该行Set mtd = Sheets("SplitMethod")中，将名称更改为源工作表的名称。将下一行中的 B1 和 B2 更改为目标列，保留 1 和 2。这假设您的列在第 1 行中有一个标题。如果没有标题，也将 B2 更改为 B1。

Sub JustDoIt()
    'working for active sheet
    'copy to the end of sheets collection
    Worksheets("SplitMethod").Activate
    ActiveSheet.Copy after:=Sheets(Sheets.Count)
    Dim tmpArr As Variant
    Dim Cell As Range
    Dim mtd As Worksheet
    Set mtd = Sheets("SplitMethod")

    For Each Cell In mtd.Range("B1", mtd.Range("B2").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 4

这是一个公式解决方案：

单元格J1是分隔符。在这种情况下，换行符。

Helper:=SUM(D1,LEN(C1)-LEN(SUBSTITUTE(C1,$J$1,"")))+1

您必须再将上述公式填写一排。

F1:=a1

将此公式填入右侧。

F2:=LOOKUP(ROW(1:1),$D:$D,A:A)&""

向右和向下填写此公式。

H2:=MID($J$1&LOOKUP(ROW(B1),$D:$D,C:C)&$J$1,FIND("艹",SUBSTITUTE($J$1&LOOKUP(ROW(B1),$D:$D,C:C)&$J$1,$J$1,"艹",ROW(B2)-LOOKUP(ROW(B1),$D:$D)))+1,FIND("艹",SUBSTITUTE($J$1&LOOKUP(ROW(B1),$D:$D,C:C)&$J$1,$J$1,"艹",ROW(B2)-LOOKUP(ROW(B1),$D:$D)+1))-FIND("艹",SUBSTITUTE($J$1&LOOKUP(ROW(B1),$D:$D,C:C)&$J$1,$J$1,"艹",ROW(B2)-LOOKUP(ROW(B1),$D:$D)))-1)&""

填写下来。

漏洞：

数字将转换为文本。当然你可以去掉公式末尾的&""，但是空白单元格会被0填充。

Answer 5

上面的宏对我不起作用。我尝试了一种简单的非基于宏的方法来做到这一点。对于我们的示例，假设您只有两列 A 和 B。B 的内容带有换行符。

1. 根据换行符将第二列（B列）拆分为多列，并提供特殊的分隔符CTRL+J（数据->文本到列）
2. 复制 A、B 列并粘贴到新工作表的 A、B 列中的不同工作表中。
3. 复制 A、C 列并粘贴粘贴到新工作表 A、B 列的第一组数据下方。
4. 重复此操作，直到原始工作表中的列没有任何数据。
5. 在新工作表中，删除 B 列为空的所有行。