VBAを使用してフォルダ内のすべてのExcelファイルを1つのファイルにコピーするとランタイムエラーが発生する

Question

VBAを使用してディレクトリ内のすべてのExcelファイル（この場合はc：\ temp）を開いてすべてのファイルデータシートを1つの大きなファイル。それぞれの新しいシートには、元のドキュメント上のファイル名とシート名が付けられます。私が持っているコードは、最初のファイルの最初のシートをコピーし、正しく名前を付けますが、ランタイムエラーで失敗します。1004：名前を設定しようとすると、アプリケーション定義またはオブジェクト定義エラーが2番目のシートにあります。誰でもどのように修正するかに関する提案があります。

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 

End Subの

Answer 1

あなたはsWSNameを定義する必要があります（私は読みやすさのためにそれを分離）

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

で

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

を交換してください。

以下は、これまでに使用していた変更された機能です。

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 

このコードを（または、この程度の）投稿はラインの外にある場合、私はまだ合理的な応答に対して必要な努力のレベルを条件に来ていて、私に知らせてください。