Copy/Paste between workbooks (Subscript out of range)

Question

I'm having troubles figuring out the problem with my code. I am running through a folder, creating a sheet based on the filename, copying a single cell (A1) and passing it in the new sheet. However, I keep get the following error:

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

I have the following code:

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

Can anyone see what is wrong in the code? Thanks in advance.

Answer 1

This should resolve the problem. You were not opening the workbook prior to doing the copy/paste.

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