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 

---

편집을 사용에만 값을 붙여, 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