在工作簿之间复制/粘贴（下标超出范围）

我有麻烦找出我的代码的问题。 我正在运行一个文件夹，根据文件名创build一个工作表，复制一个单元格（A1）并将其传递到新工作表中。 但是，我不断收到以下错误：

下标超出范围（运行时错误“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