在 VBA 中复制/粘贴多行答案

【问题标题】：Copy/Paste multiple rows in VBA在 VBA 中复制/粘贴多行
【发布时间】：2019-09-09 21:03:25
【问题描述】：

我正在尝试在工作簿中进行简单的复制行、粘贴行。我搜索了线程并尝试多次更改我的代码无济于事。

最接近工作的是这个，但它只复制一个匹配条件的实例。

我正在尝试创建一个循环，该循环将复制在其中一列中匹配的所有行。

因此，如果有 8 列，则第 7 列中具有匹配值的每一行都应复制到命名工作表。

Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long

    For Each cell In MR
    
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
    End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
    End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
    End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
    End If
    
Application.CutCopyMode = False

Next

End Sub

我喜欢这样，因为我需要使用不同的条件来定位多个目标工作表，但我需要复制所有符合条件的行。

【问题讨论】：

标签： vba copy rows

【解决方案1】：

响应新请求的编辑代码：

下面的代码将复制 Sheet Main 中的所有行，并根据第 7 列中的值将它们粘贴到相应的工作表中。

请注意：如果第 7 列中的值与现有工作表名称不匹配，则代码将引发错误。修改代码以处理该异常。

如果需要任何其他帮助，请告诉我。

Sub CopyStuff()
    Dim wsMain As Worksheet
    Dim wsPaste As Worksheet
    Dim rngCopy As Range
    Dim nLastRow As Long
    Dim nPasteRow As Long
    Dim rngCell As Range
    Dim ws As Worksheet

    Const COLUMN_TO_LOOP As Integer = 7

    Application.ScreenUpdating = False

    Set wsMain = Worksheets("Main")
    nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
    Set rngCopy = wsMain.Range("A2:H" & nLastRow)

    For Each ws In ActiveWorkbook.Worksheets
        If UCase(ws.Name) = "MAIN" Then
            'Do Nothing for now
        Else
            Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
        End If
    Next ws

    For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
        On Error Resume Next
        Set wsPaste = Worksheets(rngCell.Value)
        On Error GoTo 0

        If wsPaste Is Nothing Then
            MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
        Else

            nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1

            wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
        End If

        Set wsPaste = Nothing
    Next rngCell

    Application.ScreenUpdating = True
End Sub

【讨论】：

谢谢。它只是给了我一个运行时间错误'9'：set wsPaste=Worksheets(rngCell.Value) 的下标超出范围。
第 7 列中每一行的第 7 列值的名称是否存在工作表。要引用原始帖子中的示例，G 列中的单元格具有“X”值。该行移动到名为“X”的工作表。这适用于所有行吗？此外，是否有任何行被复制到任何工作表中？
所以它确实复制了第一个实例。所以第一个 X 值被粘贴到 X 表中。因此，在我正在使用的测试工作簿中，我在 G 列中有 11 个 X 实例。每次运行它时，它都会将同一个实例复制到目标工作表上第一个实例的下方。
G 列有空白单元格吗？我使用从您的原始帖子中收集的所有信息创建了一个测试工作簿，并且没有任何问题。这使我相信我误解了您的初始数据布局。在旁注中，我修改了代码并编辑了我的原始答案。这个新版本将检查工作表是否存在，并在工作表不存在时显示一个消息框。记下不存在的工作表名称的消息。
太完美了。有一个例子是工作表和参考不匹配。运行得很漂亮。谢谢！一项跟进请求。粘贴前是否可以清除目标单元格？我想避免复制粘贴的信息。

【解决方案2】：

您当前的代码一遍又一遍地粘贴到每张工作表中的同一行，粘贴到 A 列中具有值的最后一行。Range("A" & Rows.Count).End(xlUp) 说，大致是“转到 A 列中电子表格的最底部，然后然后从那里跳到 A 列中包含内容的下一个最低单元格，”这让你每次都回到同一个单元格。

相反，您可以使用图案的线条：

Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial

其中UsedRange 是一个范围，其中包含工作表上所有包含数据的单元格。 + 1 将您放在下一行。

您可以使用With 将其变得更漂亮：

With Sheets("X")    
  .Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial    
End With

【讨论】：