vba 在换行符处拆分单元格中的文本
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19851951/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Split text in cells at line breaks
提问by user2967539
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).
我正在处理一个包含 39 列数据的 Excel 电子表格。其中一列，即列 AJ，是一个描述字段，包含详细描述行项目的文本。单元格内的此文本有时会超过一行，并且已通过按 (ALT+Enter) 开始新行。
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 linein column AJ, as follows:
我需要能够复制整个工作表并将其全部放在另一个工作表（现有工作表）中，但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
This is the required result:
这是所需的结果：
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
But it is not working, maybe I have adapted it incorrectly.
但它不起作用，也许我没有正确地调整它。
回答by Kazimierz Jawor
Try with this code:
尝试使用此代码：
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
之前-----------------------------------------之后
回答by joshhemphill
Use =SUBSTITUTE(A1,CHAR(10),";"to replace line-breaks with ";" or some other delineator so the text-to-column can parse it for you with one of the available delineators.
用于=SUBSTITUTE(A1,CHAR(10),";"用“;”替换换行符 或其他一些描述器，以便文本到列可以使用可用的描述器之一为您解析它。
回答by anakaine
I had some issues getting Kazimierz code to work until I specified exactly which sheet it should be targeting. My scenario was a multi sheet arrangement and through some investigation I found the code was focussing on other sheets in the second nested loop - for unknown reason. Should the code not work for you, I suggest trying the below snippet.
在我准确指定它应该针对哪个工作表之前，我在让 Kazimierz 代码工作之前遇到了一些问题。我的场景是多页安排，通过一些调查，我发现代码专注于第二个嵌套循环中的其他工作表 - 原因不明。如果代码不适合您，我建议尝试以下代码段。
In the line Set mtd = Sheets("SplitMethod")change the name to that of your source sheet.
Change B1 and B2 in the next line to your target column, leaving 1 and 2 in place. This assumes your columns had a header in row 1. If there's no header, Change B2 to B1 also.
在该行中，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
回答by ambassallo
The above macros did not work for me. I tried a simple non macro based way to do this. For our example let us assume you have only two columns A and B. B has your content with the newline character.
上面的宏对我不起作用。我尝试了一种简单的非基于宏的方法来做到这一点。对于我们的示例，让我们假设您只有两列 A 和 B。 B 包含带有换行符的内容。
- Split the second column ( Column B) based on newline in to multiple columns and give special delimiter CTRL+J (Data --> Text to Columns)
- Copy column A,B and paste in a different sheet in Column A,B of new sheet.
- Copy column A,C and paste paste below the first set of data in Column A,B of new sheet.
- Repeat this until the column in original sheet does not have any data.
- In the new sheet delete all rows where column B is empty.
- 根据换行符将第二列（B 列）拆分为多列，并提供特殊分隔符 CTRL+J（数据 --> 文本到列）
- 复制 A、B 列并粘贴到新工作表的 A、B 列中的不同工作表中。
- 复制 A、C 列并粘贴到新工作表 A、B 列中第一组数据的下方。
- 重复此操作，直到原始工作表中的列没有任何数据。
- 在新工作表中删除 B 列为空的所有行。
回答by user3471272
Here is a formula solution:
这是一个公式解决方案：
Cell J1is the delimiter. In this case a line break.
单元格J1是分隔符。在这种情况下换行。
Helper:=SUM(D1,LEN(C1)-LEN(SUBSTITUTE(C1,$J,"")))+1
You must fill the above formula one row more.
您必须将上述公式再填写一行。
F1:=a1
Fill this formula to the right.
把这个公式填到右边。
F2:=LOOKUP(ROW(1:1),$D:$D,A:A)&""
Fill this formula to the right and down.
向右和向下填充此公式。
H2:=MID($J&LOOKUP(ROW(B1),$D:$D,C:C)&$J,FIND("ܳ",SUBSTITUTE($J&LOOKUP(ROW(B1),$D:$D,C:C)&$J,$J,"ܳ",ROW(B2)-LOOKUP(ROW(B1),$D:$D)))+1,FIND("ܳ",SUBSTITUTE($J&LOOKUP(ROW(B1),$D:$D,C:C)&$J,$J,"ܳ",ROW(B2)-LOOKUP(ROW(B1),$D:$D)+1))-FIND("ܳ",SUBSTITUTE($J&LOOKUP(ROW(B1),$D:$D,C:C)&$J,$J,"ܳ",ROW(B2)-LOOKUP(ROW(B1),$D:$D)))-1)&""
Fill down.
填下来。
Bug:
漏洞：
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
数字将转换为文本。当然你可以去掉公式末尾的&""，但是空白单元格会用0填充。
