VBA将文件夹中的所有Excel文件复制到单个文件会导致运行时错误

我正在尝试使用VBA打开目录中的所有excel文件（在本例中为c：\ temp），并将所有文件数据表放在一个大文件中。 每个新工作表都以文件名和原始文档上工作表的名称命名。 我已经拷贝了第一个文件的第一张表格，甚至将其正确命名的代码，但是当我尝试设置名称时，第二张表格中的运行时错误1004：应用程序定义错误或对象定义错误失败。 任何人有任何build议如何解决。

Sub MergeAllWorkbooks() Dim FolderPath As String Dim FileName As String ' Create a new workbook Set FileWorkbook = Workbooks.Add(xlWBATWorksheet) ' folder path to the files you want to use. FolderPath = "C:\Temp\" ' Call Dir the first time, pointing it to all Excel files in the folder path. FileName = Dir(FolderPath & "*.xl*") ' Loop until Dir returns an empty string. Do While FileName <> "" ' Open a workbook in the folder Set WorkBk = Workbooks.Open(FolderPath & FileName) Dim currentSheet As Worksheet Dim sheetIndex As Integer sheetIndex = 1 Windows(WorkBk.Name).Activate For Each currentSheet In WorkBk.Worksheets currentSheet.Select currentSheet.Copy Before:=Workbooks(FileWorkbook.Name).Sheets(sheetIndex) FileWorkbook.Sheets(sheetIndex).Name = FileName & "-" & currentSheet.Name sheetIndex = sheetIndex + 1 Next currentSheet ' Close the source workbook without saving changes. WorkBk.Close savechanges:=False ' Use Dir to get the next file name. FileName = Dir() Loop 

结束小组

Answer 1

更换

 FileWorkbook.Sheets(sheetIndex).Name = FileName & "-" & currentSheet.Name 

与（为了可读性我分开了）

 sWSName = FileName & "-" & currentSheet.Name sWSName = NameTest(sWSName) sWSName = TestDup(sWSName) FileWorkbook.Sheets(sheetIndex).Name = sWSName 

您将需要定义sWSName。

以下是我以前使用过的修改后的function。

 Function NameTest(sName As String) As String NameTest = sName aSpecChars = Array("\", "/", "*", "[", "]", ":", "?") For Each c In aSpecChars NameTest = Replace(NameTest, c, "") Next c If Len(sName) > 31 Then NameTest = Left(sName, 31) End Function Function TestDup(sWSName As String) As String TestDup = sWSName For Each ws In Worksheets Debug.Print ws.Name If sWSName = ws.Name Then TestDup = TestDup(Left(sWSName, Len(sWSName) - 1)) Next ws End Function 

如果发布这个代码（或在这个范围内）是不符合要求的，请告诉我，因为我仍然接受努力的要求与合理的回应。