Question

我试图将两行Sheet1（随机且基于某些条件）转移到Sheet3中。

单元格“ P2”和“ P5”中的值表示要传输的行号，列“ A”具有行号。

“ P2”和“ P5”中的值不可能匹配“ A”列中的多行。它们应分别匹配1行，因此每个“ P2”和“ P5”仅应复制一行。但是，有时我会看到多行被复制。

下面是代码：

Sub copyrows()

    Dim tfRow As Range, cell As Object

    Set tfRow = Range("A1:A") 'Range which includes the values

    For Each cell In tfRow

        If IsEmpty(cell) Then
        Exit Sub
        End If

        If cell.Value = Range("P2").Value Then
        cell.EntireRow.Copy
        Sheet3.Select  'Target sheet
        ActiveSheet.Range("A65536").End(xlUp).Select
        Selection.Offset(1, 0).Select
        ActiveSheet.Paste
        End If

    Next
End Sub


Sub copyrows2()

    Dim tfRow2 As Range, cell As Object

    Set tfRow2 = Range("A1:A") 'Range which includes the values

    For Each cell In tfRow2

        If IsEmpty(cell) Then
        Exit Sub
        End If

         If cell.Value = Range("P5").Value Then
        cell.EntireRow.Copy
        Sheet3.Select  'Target sheet
        ActiveSheet.Range("A65536").End(xlUp).Select
        Selection.Offset(1, 0).Select
        ActiveSheet.Paste
        End If

    Next
End Sub

Answer 1

正如@urdearboy在上面的通信中提到的那样，您需要在第二个A列范围中添加一行，以免出现错误。

要合并两个条件，请在您的Or中添加一个If。

要更快地运行代码，请不要Select和Activate使用不同的工作表，这需要很长时间才能运行代码。而是使用Range对象，例如CopyRng，并且每当if条件成立时，就可以使用Union函数将该单元格添加到范围中。阅读HERE中有关Union功能的信息。

下面的代码注释中有更多注释。

修改后的代码

Option Explicit

Sub copyrows()

Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long

Set Sht1 = Sheet1
Set Sht3 = Sheet3

With Sht1
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A

    Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values

    For Each C In tfRow

        If IsEmpty(C) Then
            Exit Sub
        End If

        If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
            If Not CopyRng Is Nothing Then
                Set CopyRng = Application.Union(CopyRng, C)  ' use Union to merge multiple ranges
            Else
                Set CopyRng = C
            End If
        End If

    Next C
End With

' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
    ' get last row with data in "sheet3"
    LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row

    CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If

End Sub

将行转移到另一张纸上

1 个答案: