VBAのダイナミックレンジをコピーして貼り付けるエラー：オブジェクトワークシートの範囲

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 

---

編集を使用します。値だけを貼り付けるには、user3598756が提案のようにどちらかだけで、範囲の.Valueプロパティを設定します。

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

または使用をオプションのPasteSpecialオプション：

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