VBA常用小代码202：汇总多个工作簿首个工作表数据到总表

有时后我觉得自己 像一只小小鸟 想要飞 却怎么样也飞不 也许有一天我栖上枝头 却成为猎人的目标……

诸君晚上好，今天我们聊如何汇总多个工作簿首个工作表的数据到总表。

这事儿常用的方法有三种，一种是SQL语句，一种是Power Query，还有一种就是VBA了。

相比前两种方法，VBA有更好的灵活性。

举栗，它可以允许标题行存在合并单元格，可以允许标题行存在多行，甚至可以允许数据明细区域有乱七八糟的合并单元格……等等。

不过，面对过于复杂的问题需要对代码细节作对应的调整……这也就需要诸君不但有代码阅读能力，也要有一定的代码调整能力……

照例VBA动画操作：

代码如下：

---

Sub Collectwk()

    'ExcelHome VBA编程学习与实践

    Dim Trow&, k&, arr, brr, i&, j&, book&, a&

    Dim p$, f$, Rng As Range

    With Application.FileDialog(msoFileDialogFolderPicker)

    '取得用户选择的文件夹路径

        .AllowMultiSelect = False

        If .Show Then p = .SelectedItems(1) Else Exit Sub

    End With

    If Right(p, 1) <> '\' Then p = p & '\'

    '

    Trow = Val(InputBox('请输入标题的行数', '提醒'))

    If Trow < 0 Then MsgBox '标题行数不能为负数。', 64, '警告': Exit Sub

    Application.ScreenUpdating = False '关闭屏幕更新

    Cells.ClearContents '清空当前表数据

    Cells.NumberFormat = '@' '设置单元格格式为文本

    ReDim brr(1 To 200000, 1 To 1)

    '定义装汇总结果的数组brr，最大行数为20万行

    f = Dir(p & '*.xls*')

    '开始遍历指定文件夹路径下的每个工作簿

    Do While f <> ''

        If f <> ThisWorkbook.Name Then '避免同名文件重复打开出错

            With GetObject(p & f)

            '以\'只读\'形式读取文件时，使用getobject方法会比workbooks.open稍快

                Set Rng = .Sheets(1).UsedRange

                If IsEmpty(Rng) = False Then '如果工作表非空

                    book = book 1 '标记一下是否首个Sheet,如果首个sheet，BOOK=1

                    a = IIf(book = 1, 1, Trow 1) '遍历读取arr数组时是否扣掉标题行

                    arr = Rng.Value '数据区域读入数组arr

                    If UBound(arr, 2) > UBound(brr, 2) Then

                    '动态调整结果数组brr的最大列数，避免明细表列数不一的情况。

                        ReDim Preserve brr(1 To 200000, 1 To UBound(arr, 2))

                    End If

                    For i = a To UBound(arr) '遍历行

                        k = k 1 '累加记录条数

                        For j = 1 To UBound(brr, 2) '遍历列

                            brr(k, j) = arr(i, j)

                        Next

                    Next

                End If

                .Close False '关闭工作簿，不保存。

            End With

        End If

        f = Dir '下一个工作簿

    Loop

    If k > 0 Then

        [a1].Resize(k, UBound(brr, 2)) = brr

        MsgBox '汇总完成。'

    End If

    Application.ScreenUpdating = True '恢复屏幕更新

End Sub

---

绕口令：

该段代码只是汇总指定文件夹下每个工作簿的第一张工作表的数据，且限定了汇总后最大行数为20万行；下期我们再分享如何汇总指定文件夹下每个工作簿多个工作表表名包含某个关键词数据的代码——能一口气读完这段话我扶你过马路不怕讹~

一码不扫，
可以扫天下？

ExcelHome

VBA编程学习与实践