在换行符的单元格中拆分文本并复制到新工作表

我有一张数据表。 在一列中，文本需要用逗号分隔，并分成若干行。 我有一个工程的子，但我希望它复制结果到指定的工作表，而不是创build一个新的工作表。 我不是最大的VBA所以我不知道如何操纵代码。 先谢谢你！

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

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

这是所需的结果：

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

我已经search了类似的代码论坛，但我无法适应自己的目的。

在这里input图像说明

 Sub JustDoIt() 'copy to the end of sheets collection 'Worksheets("Data").Activate ActiveSheet.Copy after:=Sheets(Sheets.Count) Dim tmpArr As Variant Dim Cell As Range For Each Cell In Range("A5", Range("A6").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.InsertlShiftDown Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr) End If Next Application.CutCopyMode = False End Sub 

旧代码使用的是：

 Sub SplitHoursPerDay() Dim Temp As Variant Dim CText As String Dim J As Integer Dim K As Integer Dim L As Integer Dim iColumn As Integer Dim lNumCols As Long Dim lNumRows As Long iColumn = 10 Set wksSource = Sheet4 Set wksNew = Sheet5 iTargetRow = 0 With wksSource lNumCols = .Range("AK1").End(xlToLeft).Column lNumRows = .Range("A700").End(xlUp).Row For J = 1 To lNumRows CText = .Cells(J, iColumn).Value Temp = Split(CText, Chr(10)) For K = 0 To UBound(Temp) iTargetRow = iTargetRow + 1 For L = 1 To lNumCols If L <> iColumn Then wksNew.Cells(iTargetRow, L) _ = .Cells(J, L) Else wksNew.Cells(iTargetRow, L) _ = Temp(K) End If Next L Next K Next J End With End Sub 

Answer 1

我认为这是你想要的。 您需要指定输出表的名称。

 Sub JustDoIt() Dim tmpArr As Variant, rCell As Range, v, i As Long, v2(), j As Long, k As Long Dim ws1 As Worksheet, ws2 As Worksheet, n As Long Set ws1 = ActiveSheet Set ws2 = Sheets("Output") 'You need to specify a sheet here v = ws1.Range("A1").CurrentRegion.Value ReDim v2(1 To UBound(v, 1) * 100, 1 To UBound(v, 2)) n = 1 For i = LBound(v, 1) To UBound(v, 1) tmpArr = Split(v(i, 10), Chr(10)) For k = 0 To UBound(tmpArr) For j = LBound(v, 2) To UBound(v, 2) v2(n, j) = v(i, j) Next j v2(n, 10) = tmpArr(k) n = n + 1 Next k Next i ws2.Range("A1").Resize(n, UBound(v2, 2)) = v2 End Sub