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

我正在制作一个Excel电子表格，其中有39列数据。其中一列（列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

但它不起作用，可能是我修改不正确。

请尝试使用以下代码：

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

Sub JustDoIt（）
'为活动工作表工作
'复制到图纸集合的末尾
ActiveSheet.Copy after:=工作表（工作表.计数）
Dim tmpArr作为变体
暗淡单元格作为范围
对于范围内的每个单元格（“AJ1”，范围（“AJ2”）。结束（xlDown））
如果InStr（1，Cell，Chr（10））为0，则
tmpArr=拆分（单元，Chr（10））
Cell.EntireRow.Copy
单元格偏移量（1，0）。调整大小（UBound（tmpArr），1）_
EntireRow.插入xlShiftDown
Cell.Resize（UBound（tmpArr）+1,1）=Application.Transpose（tmpArr）
如果结束
下一个
Application.CutCopyMode=False
端接头

之前-------------------------------------之后

---

在我明确指定Kazimierz代码的目标工作表之前，我在使用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

Sub JustDoIt（）
'为活动工作表工作
'复制到图纸集合的末尾
工作表（“拆分方法”）。激活
ActiveSheet.Copy after:=工作表（工作表.计数）
Dim tmpArr作为变体
暗淡单元格作为范围
将mtd调整为工作表
设置mtd=图纸（“拆分方法”）
对于mtd范围（“B1”、mtd范围（“B2”）中的每个单元格，结束（xlDown））
如果InStr（1，Cell，Chr（10））为0，则
tmpArr=拆分（单元，Chr（10））
Cell.EntireRow.Copy
单元格偏移量（1，0）。调整大小（UBound（tmpArr），1）_
EntireRow.插入xlShiftDown
Cell.Resize（UBound（tmpArr）+1,1）=Application.Transpose（tmpArr）
如果结束
下一个
Application.CutCopyMode=False
端接头

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

根据换行符将第二列（B列）拆分为 多列，并为其指定特殊分隔符CTRL+J（数据-->文本） （列）

复制A、B列并粘贴到新工作表A、B列中的其他工作表中

复制A、C列，并在新工作表A、B列的第一组数据下方粘贴粘贴

重复此操作，直到原始工作表中的列没有任何数据

在新工作表中，删除列B为空的所有行

---

以下是一个公式解决方案：

单元格

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。

使用

=SUBSTITUTE（A1，CHAR（10），“；”）

将换行符替换为“；”或者其他一些描述器，以便文本到列可以使用可用的描述器之一为您解析。

您能告诉我们您尝试了什么吗？您必须使用一些公式来实现此一般逻辑：首先复制工作表，然后只查看列A，以查看行中的单元格是否为空。如果它是空的，用上面的那一行填充A&B并移到下一行。我想不出一个宏或vbscript现在可以这样做。您可能需要在这里使用excel中的“数据>文本到列”功能进行一些手动操作，并选中“其他”复选框，然后按Ctrl+J作为分隔符。这将在每个车厢中分隔文本return@Chelseawillrecover我应该提到的是，这是一项需要反复完成的任务，因此我需要使用宏来实现自动化。此外，我无法使文本到列用于行。感谢KazJaw，它在宏的第一部分工作得很好，它现在正在为单元格中的每一行创建一个新行，但是它不会在行之间拆分文本。例如，AJ列中包含5行的单元格已被复制到新行5次，这是我想要的，但它没有在行之间拆分文本。对不起，我现在不明白您的问题。试着自己去弄清楚。正如你所看到的，你有一个解决方案，它可以解决屏幕截图上显示的问题。我不知道为什么，但我没有得到与你相同的结果。例如，AJ2和AJ3具有相同的文本（AAA BBB）等等。我已经制作了一个新的工作表，并完全复制了您正在做的事情，并且工作正常。对不起，你的代码没有问题，你有什么建议为什么它对我不起作用吗？所有的工作卡兹贾夫，我这方面的愚蠢错误，非常感谢你的帮助