在VBA上复制和粘贴动态范围，错误：object_worksheet的范围，

Question

我已经写入/散列过一个程序，用于复制一行数据，当行符合某个标准（列A =“1”）工作簿位于桌面上的测试文件夹中;该计划最初的工作，但现在在这里拉了一个错误：

ws.Range(ws.Cells(r, 1), Cells(r, 20)).Copy Destination:=ThisWorkbook.Sheets("SummaryAccrual").Range("A" & lr2 + 1) 

一旦进行排序，我也担心，复制和粘贴此方法将粘贴公式，而不是值，有一个简单的方法来粘贴值？

感谢您的帮助，我非常感谢！

我的代码

Option Explicit 

Sub AccrualCombiner() 

Dim Path As String 
Dim FileName As String 
Dim Wkb As Workbook 
Dim cWkb As Workbook 
Dim ws As Worksheet 
Dim answer As Integer 
Dim lr As Long, lr2 As Long, r As Long 
Dim rc As Object 

Application.EnableEvents = False 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
Application.AskToUpdateLinks = False 

answer = MsgBox("Would you like to combine Accruals for current period?", vbYesNo + vbQuestion, "Confirmation") 

If answer = vbYes Then 
    Set cWkb = Application.ActiveWorkbook 
    lr2 = ThisWorkbook.Sheets("SummaryAccrual").Cells(Rows.Count, "A").End(xlUp).Row 

    Path = "C:\Users\alexander.neale\Desktop\Test" 
    FileName = Dir(Path & "\*.xls", vbNormal) 

    Do Until FileName = "" 

     Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName) 
     For Each ws In Wkb.Worksheets 
      For r = 14 To 60 Step 1 
       If ws.Range("A" & r).Value = "1" Then 
        ws.Range(ws.Cells(r, 1), Cells(r, 20)).Copy Destination:=ThisWorkbook.Sheets("SummaryAccrual").Range("A" & lr2 + 1) 
        lr2 = ThisWorkbook.Sheets("SummaryAccrual").Cells(Rows.Count, "A").End(xlUp).Row 
       End If 
      Next r 
     Next ws 
     Wkb.Close False 
     FileName = Dir() 
    Loop 

    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.AskToUpdateLinks = True 
End If 

End Sub 

Answer 1

这是你的问题：

ws.Range(ws.Cells(r, 1), Cells(r, 20)).Copy 

第二Cells没有指定所以它会假设你的意思是活动表板。如果活动工作表不是ws，那么它将失败，因为范围不能跨越多个工作表。因此，使用

ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Copy 

或

With ws 
    .Range(.Cells(r, 1), .Cells(r, 20)).Copy .... 
End With 

---

编辑：粘贴仅值，无论是刚刚设置的范围.Value财产，像user3598756建议：

ThisWorkbook.Sheets("SummaryAccrual").Range("A" & lr2 + 1).Resize(1, 20).Value = ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Value 

或使用PasteSpecial与xlPasteValues选项：

ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Copy 
ThisWorkbook.Worksheets("SummaryAccrual").Range("A" & lr2 + 1).PasteSpecial xlPasteValues 

第一个选项通常要快得多。

Answer 2

，因为你关注的只是粘贴值，这应该是更快：

Option Explicit 

Sub AccrualCombiner() 
    Dim Path As String 
    Dim FileName As String 
    Dim Wkb As Workbook 
    Dim ws As Worksheet 
    Dim answer As Integer 
    Dim r As Long 

    answer = MsgBox("Would you like to combine Accruals for current period?", vbYesNo + vbQuestion, "Confirmation")   
    If answer = vbYes Then 
     Application.EnableEvents = False 
     Application.ScreenUpdating = False 
     Application.DisplayAlerts = False 
     Application.AskToUpdateLinks = False 

     Path = "C:\Users\alexander.neale\Desktop\Test" 
     With ThisWorkbook.Worksheets("SummaryAccrual") 
      FileName = Dir(Path & "\*.xls", vbNormal) 
      Do Until FileName = "" 
       Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName) 
       For Each ws In Wkb.Worksheets 
        If WorksheetFunction.CountIf(ws.Range(ws.Cells(14, 1), ws.Cells(60, 1)), "1") > 0 Then 
         For r = 14 To 60 Step 1 
          If ws.Range("A" & r).Value = "1" Then 
           .Cells(.Rows.COUNT, "A").End(xlUp).Offset(1).Resize(, 20).Value = ws.Range(ws.Cells(r, 1), ws.Cells(r, 20)).Value 
          End If 
         Next r 
        End If 
       Next ws 
       Wkb.Close False 
       FileName = Dir() 
      Loop 
     End With 

     Application.EnableEvents = True 
     Application.ScreenUpdating = True 
     Application.DisplayAlerts = True 
     Application.AskToUpdateLinks = True 
    End If 
End Sub