我正在开发一个包含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
但它不起作用,也许我已经错误地调整了它。
答案 0 :(得分:13)
尝试使用此代码:
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 强>
答案 1 :(得分:1)
我有一些问题让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
答案 2 :(得分:0)
上述宏对我不起作用。我尝试了一种简单的非基于宏的方法来做到这一点。 对于我们的示例,我们假设您只有两列A和B. B的内容包含换行符。
答案 3 :(得分:0)
这是一个公式解决方案:
单元格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)&""
填写。
错误:
数字将转换为文字。当然,您可以删除公式末尾的&amp;“”,但空白单元格将填充0。
答案 4 :(得分:0)
使用=SUBSTITUTE(A1,CHAR(10),";"
替换换行符&#34;;&#34;或其他一些描述符,以便文本到列可以使用其中一个可用的描述符为您解析。