Excel VBA无需选择即可从一张纸复制到另一张纸

Question

I am trying to copy only selected ranges from one sheet to another based on the contents of a few cells. The code I developed works up to the point that I try to actually copy and paste the information. I have reviewed many sites with similar code, the difference is I'm trying to execute to a certain range.

I get the following error: Run-time error '1004': Appliction - defined or object-defined error

My code is as follows:

    Option Explicit
    Sub CopyRed()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim LastRow1 As Integer
    Dim LastRow2 As Integer
    Dim check As Integer
    Dim Cond1 As String
    Dim Cond2 As String
    Dim Cond3 As String
    Dim i as Integer

    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)

    'set search criteria
    'define # rows in tool tracker
    Cond1 = ws1.Cells(1, 4)
    Cond2 = ws1.Cells(2, 4)
    Cond3 = ws1.Cells(3, 4)
    LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row

    'Define # rows in current red and clear
    LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    Range(ws2.Cells(2, 1), ws2.Cells(LastRow2, 70)).Clear


    If Cond1 = "ALL" Then
        For i = 6 To LastRow1
            If ws1.Cells(i, 2) = "R" Then
                LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row.Offset(1, 0)
                ws1.Range(Cells(i, 1), Cells(i, 70)).Copy ws2.Range(Cells(LastRow2, 1)) 'Error occurs here
            End If
        Next i
    Else
        For i = 6 To LastRow1
            If ws1.Cells(i, 2) = "R" Then
                If ws1.Cells(i, 4) = Cond1 Or ws1.Cells(i, 4) = Cond2 Or ws1.Cells(i, 4) = Cond3 Then
                    LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    ws1.Range(Cells(i, 1), Cells(i, 70)).Copy Destination:=ws2.Range(Cells(LastRow2, 1), Cells(LastRow2, 70)) 'Error occurs here
                End If
            End If
        Next i
    End If

    End Sub

If I change the code to just select the ranges, and step through it it selects the right ranges on both sheets. I'm sure it is something simple but I am at wits end on how to fix this. Any help would be great.

Answer 1

There were a couple of places where you had not fully qualified all your Cells references with worksheets. This will cause an error if your active sheet is different to that specified in part of your line. I also changed your Integer declarations to Long which is more efficient and will cater for larger blocks of data.

Sub CopyRed()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim check As Long
Dim Cond1 As String
Dim Cond2 As String
Dim Cond3 As String
Dim i As Long

Set ws1 = Sheets(1)
Set ws2 = Sheets(2)

'set search criteria
'define # rows in tool tracker
Cond1 = ws1.Cells(1, 4)
Cond2 = ws1.Cells(2, 4)
Cond3 = ws1.Cells(3, 4)
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row

'Define # rows in current red and clear
LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Range(ws2.Cells(2, 1), ws2.Cells(LastRow2, 70)).Clear


If Cond1 = "ALL" Then
    For i = 6 To LastRow1
        If ws1.Cells(i, 2) = "R" Then
            LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row.Offset(1, 0)
            ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 70)).Copy ws2.Cells(LastRow2, 1) 'Error occurs here
        End If
    Next i
Else
    For i = 6 To LastRow1
        If ws1.Cells(i, 2) = "R" Then
            If ws1.Cells(i, 4) = Cond1 Or ws1.Cells(i, 4) = Cond2 Or ws1.Cells(i, 4) = Cond3 Then
                LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
                ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 70)).Copy Destination:=ws2.Range(ws2.Cells(LastRow2, 1), ws2.Cells(LastRow2, 70)) 'Error occurs here
            End If
        End If
    Next i
End If

End Sub