Копирование/Вставка между книгами (Подзаголовок за пределами допустимого диапазона)

Question

У меня возникли проблемы с выяснением проблемы с моим кодом. Я запускаю папку, создавая лист на основе имени файла, копируя одну ячейку (A1) и передавая ее на новом листе. Тем не менее, я продолжаю получать следующее сообщение об ошибке:

Subscript out of range (Run-time error '9')

У меня есть следующий код:

Sub InsertDepartments() 
    Dim MyObj As Object, MySource As Object, file As Variant 
    file = Dir(ThisWorkbook.Path & "\Departments\") 
    While (file <> "") 
     Set WS = Sheets.Add(After:=Sheets("Start")) 
     WS.Name = Left(file, InStr(file, ".") - 1) 

     Workbooks(ThisWorkbook.Path & "\Departments\" & file).Sheets("XXX").Range("A1").Copy 
     Sheets(WS.Name).Range("A1").PasteSpecial Paste:=xlPasteValues 

     file = Dir 
    Wend 

End Sub 

Может кто-нибудь увидеть, что не так в коде? Заранее спасибо.

Answer 1

Это должно решить проблему. Вы не открывали книгу до копирования/вставки.

Sub InsertDepartments() 
    Dim wbOutput As Workbook 
    Dim wsOutput As Worksheet 
    Dim wbSource As Workbook 
    Dim file As Variant 

    file = Dir(ThisWorkbook.Path & "\Departments\*.xls*") 
    Set wbOutput = ActiveWorkbook 

    While (file <> "") 

     Set wsOutput = wbOutput.Sheets.Add(After:=wbOutput.Sheets("Start")) 
     wsOutput.Name = Left(file, InStr(file, ".") - 1) 
     Set wbSource = Workbooks.Open(ThisWorkbook.Path & "\Departments\" & file) 
     wbSource.Sheets("XXX").Cells.Copy 
     wsOutput.Range("A1").PasteSpecial xlPasteValues 
     Application.CutCopyMode = False 
     wbSource.Close False 
     file = Dir 
    Wend 

End Sub