Excel VBA从一张纸复制到另一张没有选择

Question

我想根据几个单元格的内容仅将选定范围从一张纸复制到另一张。我开发的代码工作到了我试图实际复制和粘贴信息的程度。我已经审查了许多类似代码的网站，区别在于我试图执行到一定范围内。

我收到以下错误：运行时错误“1004”：机应用 - 定义或对象定义的错误

我的代码如下：

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 

如果我更改代码以刚选择范围，然后逐步选择它在两张纸上选择正确的范围。我敢肯定这是简单的事情，但我很快就会知道如何解决这个问题。任何帮助都会很棒。

Answer 1

有几个地方你没有完全限定你所有的单元格参考工作表。如果您的活动工作表与您的部分行中指定的活动工作表不同，则会导致错误。我也将你的Integer声明改为Long，这样更高效，并且会迎合更大的数据块。

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