excel - Transferring rows into another sheet

Question

I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.

The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.

There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.

Below is the code:

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

标签： excelvba

Answer 1

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

要合并两个条件，在您的情况下添加一个Or到您的If.

为了更快地运行代码，不要Select和Activate不同的工作表，代码运行需要很长时间。相反，请使用一个Range对象，例如CopyRng，每次条件正常时，您都可以使用该函数if将该单元格添加到范围中。在此处Union阅读有关该功能的信息。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