在换行符中拆分单元格中的文本 [英] Split text in cells at line breaks

问题描述

我正在使用具有39列数据的Excel电子表格。这些列之一列AJ是一个描述字段，并且包含描述行项目的详细信息。单元格内的这个文本有时是一行以上，按（ALT + Enter）开始新行。

I am working on an Excel spreadsheet that has data in 39 columns. One of these columns, column AJ, is a description field, and contains text describing the row item in detail. This text inside the cell sometimes is more than one line long and new lines have been started by pressing (ALT+Enter).

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

I need to be able to copy the entire sheet and place it all in another sheet (existing sheet), but with a new row for each new line in column AJ, as follows:

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

我已经在论坛搜索了类似的代码，但是我无法为自己的目的调整它。

I have searched the forums for similar code, but I am having trouble adapting it for my own purpose.

更新：不知道为什么这被关闭，假设你可能想要一些代码的例子。我正在使用以下宏，我在互联网上找到：

UPDATE: Not sure exactly why this has been closed, assume you maybe want an example of some code. I was using the below macro, that I found on the internet:

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

但它不工作，也许我修改不正确。 / p>

But it is not working, maybe I have adapted it incorrectly.

推荐答案

尝试使用以下代码：

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

BEFORE -----------------------------------------的 AFTER

BEFORE-----------------------------------------AFTER

这篇关于在换行符中拆分单元格中的文本的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！