Question

VBA多个工作簿合并成一个工作簿的多个表

求一段代码。合并当前文件夹总所有工作簿。工作簿名称为A B C D E F G。合并当前目录中“汇总”工作簿中。在汇总工作簿中生成A B C D E F G sheet。 如图。合并后的效果。
麻烦请帮忙 在代码中加入，每次运行代码时会先删除除汇总sheet以外的所有表后，再合并。
谢谢！

谢谢!.
抱歉 有一句话没有叙述明白。是合并到当前目录总的汇总工作簿中。谢谢

Answer 1

附件是我自己玩的一个合并，分离，清理的一个表格你可以参考。

替换掉我模块里《合并》里面的代码，就是你要的结果。文件多了A-Z标记不下。

Sub 统计()

Dim s As FileSearch '定义一个文件搜索对象

Dim data As String

Dim mybook As Object

Dim tatol As Object

Dim xfile As Object

Dim FNR As Integer

Set mybook = Workbooks(ThisWorkbook.Name)

Set total = mybook.Worksheets("统计")

    If ThisWorkbook.Worksheets.Count > 1 Then '清理工作表

    ReDim arr(2 To ThisWorkbook.Worksheets.Count)

    For i = 2 To ThisWorkbook.Worksheets.Count

        arr(i) = i

    Next

    Worksheets(arr).Delete

    End If

    Cells.Delete '清理统计表

total.Cells(1, 1) = "文件名"

total.Cells(1, 2) = "工作表数"

total.Cells(1, 4) = "工作表名称"

Set s = Application.FileSearch

    s.LookIn = ThisWorkbook.Path '注意路径，换成你实际的路径

    s.Filename = "*.xls*" '搜索所有文件

    s.Execute '执行搜索

    FNR = 2

For i = 1 To s.FoundFiles.Count '读取除本工作表外的工作表

mybook.Activate

    If s.FoundFiles(i) <> ThisWorkbook.Path & "\" & ThisWorkbook.Name Then

    total.Cells(FNR, 1) = Replace(s.FoundFiles(i), s.LookIn & "\", "")

        Set wb = Workbooks.Open(s.FoundFiles(i))

            Workbooks(Replace(s.FoundFiles(i), s.LookIn & "\", "")).Activate

           total.Cells(FNR, 2) = Worksheets.Count

        For k = 1 To Worksheets.Count '读取每个表格中的工作表

           Set xfile = Workbooks(Replace(s.FoundFiles(i), s.LookIn & "\", "")).Worksheets(k)

             total.Cells(FNR, 4) = xfile.Name '直接复制名称

              mybook.Worksheets.Add After:=mybook.Sheets(mybook.Worksheets.Count) '插入新工作表

               mybook.Worksheets(mybook.Worksheets.Count).Name = Chr(63 + FNR) '重命名

               FNR = FNR + 1

           xfile.Activate '复制工作表

            Cells.Select

             Selection.Copy

            mybook.Worksheets(ThisWorkbook.Worksheets.Count).Activate

           Range("A1").Select

          ActiveSheet.Paste

        Next

    ClearClipboard '剪切板 清理

        wb.Close False

    End If

Next

ThisWorkbook.Worksheets(1).Select

End Sub