Excel VBA 7.13跨工作薄合并工作表，VBA来搭桥

前景提要

通过之前的学习，我们基本上能够应付日常工作中一些常见的工作表汇总的需求了，不过小伙伴们应该也已经注意到了，我们这些工作表的汇总都是在单个工作薄范围内进行的， 就是说，之前合并数据的功能，暂时无法实现跨工作薄进行，这确实还是有一定的局限性

跨工作薄合并工作表，并且一个工作薄下面有多个工作表也是经常的事情，那么我们今天就来看看，如果每个工作薄下面有多个工作表，如何实现跨工作薄来合并数据呢？

场景模拟

我们还是用之前的例子来继续演示，假设我们现在文件夹内有N个工作薄，每个工作薄的数据字段也是相同的，属于标准数据

我现在想要做的就是合并这些工作表，将他们全部合并在一个新的工作薄的工作表中，之后就能够在一个表中对所有的数据进行分析，处理了，而不用在那么多个报表里面跳来跳去

代码区

Sub sdd()Dim tbook As Workbook, book As Workbook, sth As WorksheetSet tbook = ActiveWorkbookWith Application.FileDialog(msoFileDialogFolderPicker) .Title = "请选择要汇总的工作薄所在文件夹" If .Show = -1 Then Filename = .SelectedItems(1) End IfEnd Withk = 0f = Dir(Filename & "\")Do While f <> "" Workbooks.Open Filename & "\" & f Set book = ActiveWorkbook For Each sth In book.Worksheets k = k + 1 l = tbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row If k = 1 Then sth.UsedRange.Copy tbook.Worksheets(1).Cells(1, 1) Else sth.UsedRange.Offset(1, 0).Copy tbook.Worksheets(1).Cells(l + 1, 1) End If Next sthf = Dir()ActiveWorkbook.Close FalseLoopEnd Sub

其实并不难，如果大家对于之前学习过的工作薄的合并还有印象的话，就会发现，其实思路是一样的，不过加多了一个循环而已。

看看效果

随机抽取其中一个姓名来看看，A1

总共有8个，那么我们看看我们是不是有8个工作薄

7+1总共8个工作薄，证明全部都成功的合并了

再找一个工作薄的第三个工作表的内容看看，C1,也是8个，证明，所有的工作表的数据都已经合并好了。

代码分析

With Application.FileDialog(msoFileDialogFolderPicker) .Title = "请选择要汇总的工作薄所在文件夹" If .Show = -1 Then Filename = .SelectedItems(1) End IfEnd With

简单的选择工作表的窗体代码，非常简单，我们第一系列分享的基础知识点，这里就不更多阐述了。

f = Dir(Filename & "\")Do While f <> ""f = Dir()Loop

这一段大家也是非常的熟悉了，也是第一系列的基础，遍历文件夹的方法

Workbooks.Open Filename & "\" & f Set book = ActiveWorkbook For Each sth In book.Worksheets k = k + 1 l = tbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row If k = 1 Then sth.UsedRange.Copy tbook.Worksheets(1).Cells(1, 1) Else sth.UsedRange.Offset(1, 0).Copy tbook.Worksheets(1).Cells(l + 1, 1) End If Next sth

这里就循环的主题了，我们先拆开来看，

For Each sth In book.Worksheets Next sth

这是遍历循环当前工作薄的所有工作表

看看循环内的主体

k = k + 1 l = tbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row If k = 1 Then sth.UsedRange.Copy tbook.Worksheets(1).Cells(1, 1) Else sth.UsedRange.Offset(1, 0).Copy tbook.Worksheets(1).Cells(l + 1, 1)

如果是第一次，就复制所有的区域含标题

第二次以及后面就不需要复制标题栏了，因为第一次已经复制了，已经存在了，再次复制的话，我们还需要再多做一步删除，更麻烦，所以第二次就直接跳过标题栏

这样就可以轻松实现我们的效果了，规则数据处理起来还是比较的简单的