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

Question

我正在尝试使用 VBA 打开一个目录（在本例中为 c:\temp）中的所有 excel 文件，并将所有文件数据表放在一个大文件中。每个新工作表都以文件名加上原始文档上工作表的名称命名。我的代码复制了第一个文件的第一个工作表，甚至正确命名它，但是当我尝试设置名称时，第二个工作表上出现运行时错误 1004：应用程序定义或对象定义错误。任何人都对如何修复有任何建议。

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

with（为了便于阅读，我把它分开了）

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

您需要定义 sWSName。

以下是我之前使用的修改后的函数。

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

如果发布此代码（或在此范围内）不合时宜，请告诉我，因为我仍在接受所需的努力程度与合理的响应。