在另一个工作表中复制匹配的行

Posted 2023-03-27

【中文标题】在另一个工作表中复制匹配的行

【英文标题】：Copying the matched row in another sheet

【发布时间】：2017-11-30 04:24:22

【问题描述】：

我有两张表格，表格 1 和表格 2。 如果 T 在工作表 2 中包含 1，我正在查看 sheet1 的 T 列并粘贴完整的行。 该代码运行良好，但它将结果粘贴到 sheet2 的同一行中的 sheet1 中。 这会导致行之间出现空白。任何人都可以建议，我应该用我的代码更改什么，以便我按顺序获取它们而没有任何空白行。 另外，如何将第 1 行中的 Header 从表 1 复制到表 2？

Sub Test()
For Each Cell In Sheets(1).Range("T:T")
    If Cell.Value = "1" Then
        matchRow = Cell.Row
        Rows(matchRow & ":" & matchRow).Select
        Selection.Copy

        Sheets(2).Select
        ActiveSheet.Rows(matchRow).Select
        ActiveSheet.Paste
        Sheets(1).Select
    End If
Next
End Sub

【问题讨论】：

***.com/questions/11631363/…

重新打开问题，因为 OP 不想使用自动过滤器。他想循环

【参考方案1】：

无需使用Select 和Selection 进行复制粘贴，它只会减慢代码的运行时间。

Option Explicit

Sub Test()

Dim Cell As Range
Dim NextRow as Long

Application.ScreenUpdating = False

For Each Cell In Sheets(1).Range("T1:T" & Sheets(1).Cells(Sheets(1).Rows.Count, "T").End(xlUp).Row)
    If Cell.Value = "1" Then
        NextRow = Sheets(2).Cells(Sheets(2).Rows.Count, "T").End(xlUp).Row
        Rows(Cell.Row).Copy Destination:=Sheets(2).Range("A" & NextRow + 1)
    End If
Next
Application.ScreenUpdating = True

End Sub

【讨论】：

对不起，我将不得不关闭这个问题作为重复：D

为什么会这样？

@SiddharthRout 不好 ;)

BTW 循环遍历整个Range("T:T") 真的很痛苦。自动过滤器会更快吗？

@SiddharthRout 我已修改为遍历占用范围。我认为它已经足够快了，无论如何，我认为将 VBA 初学者与AutoFilter 混淆不是那么好

【参考方案2】：

不是为了积分

抱歉，但我无法阻止自己发布答案。当我看到有人想用低劣的方式做某事时，我很痛苦:(

我不赞成循环。与Autofilter 相比，它非常慢。

如果您STILL想要使用循环，那么您可以通过不复制循环中的行但最后在ONE GO中复制来使其更快... p>

此外，如果您不喜欢危险地生活，那么请始终完全限定您的对象，否则您最终可能会复制错误的行。

Option Explicit

Sub Sample()
    Dim wsI As Worksheet, wsO As Worksheet
    Dim lRow As Long, i As Long, r As Long
    Dim copyRng As Range

    Set wsI = Sheet1: Set wsO = Sheet2

    wsO.Cells.Clear

    '~~> first available row in sheet2
    r = 2

    With wsI
        lRow = .Range("T" & .Rows.Count).End(xlUp).Row

        '~~> Copy Headers
        .Rows(1).Copy wsO.Rows(1)

        For i = 1 To lRow
            If .Range("T" & i).Value = 1 Then
                If copyRng Is Nothing Then
                    Set copyRng = .Rows(i)
                Else
                    Set copyRng = Union(copyRng, .Rows(i))
                End If
            End If
        Next i
    End With

    If Not copyRng Is Nothing Then copyRng.Copy wsO.Rows(r)
End Sub

截图