Question

我有一张数据表。在一列中，文本需要用逗号分隔并分成行。我有一个子工作，但我希望它将结果复制到指定的工作表，而不是创建一个新工作表。我对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

我在论坛上搜索了类似的代码，但我无法根据自己的目的进行调整。

enter image description here

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

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

1 个答案: