有时后我觉得自己 像一只小小鸟 想要飞 却怎么样也飞不 也许有一天我栖上枝头 却成为猎人的目标……
诸君好，今天我们聊如何汇总多个工作簿首个工作表的数据到总表。
这事儿常用的方法有三种，一种是SQL语句，一种是Power Query，还有一种就是VBA了。
相比前两种方法，VBA有更好的灵活性。
举栗，它可以允许标题行存在合并单元格，可以允许标题行存在多行，允许标题的字段不一样多，甚至可以允许分表区域有乱七八糟的合并单元格……等等。
更别提VBA拥有优秀的交互性，比如此例中允许用户在对话框中自定义标题行的行数。
照例动画操作代码运行过程：
代码如下（代码看不全可以拖动屏幕，但更建议复制到Excel中阅读）：
Sub CollectWKSheetOne() Dim lngHeadLine As Long, k As Long Dim arr, brr Dim i As Long, j As Long, lngShtCount As Long Dim strPath As String, strWKName As String Dim rngData As Range, n As Long With Application.FileDialog(msoFileDialogFolderPicker) '取得用户选择的文件夹路径 If .Show Then strPath = .SelectedItems(1) Else Exit Sub End With If Right(strPath, 1) "\" Then strPath = strPath & "\" lngHeadLine = Val(InputBox("请输入标题的行数", "提醒", 1)) If lngHeadLine < 0 Then MsgBox "标题行数不能为负数。", 64, "亲": Exit Sub Application.ScreenUpdating = False '关闭屏幕更新 Cells.Clear '清空当前表数据 Const DATA_MAXROW As Long = 50000 '结果数组最大行数 ReDim brr(1 To DATA_MAXROW, 1 To 1) '定义汇总结果的数组brr，最大行数为20万行 strWKName = Dir(strPath & "*.xls*") '开始遍历指定文件夹路径下的Excel工作簿 Do While strWKName "" If strPath ThisWorkbook.Name Then '避免同名文件重复打开出错 With GetObject(strPath & strWKName) '以\'只读\'形式读取文件时，使用getobject方法会比workbooks.open稍快 Set rngData = .Worksheets(1).UsedRange If IsEmpty(rngData) = False Then '如果工作表非空 lngShtCount = lngShtCount + 1 '标记一下汇总工作表的个数 arr = rngData.Value '数据区域读入数组arr If UBound(arr, 2) > UBound(brr, 2) Then '动态调整结果数组brr的最大列数，避免明细表列数不一的情况。 For j = UBound(brr, 2) To UBound(arr, 2) '将新增的标题写入汇总表 For i = 1 To lngHeadLine Cells(i, j).Value = arr(i, j) Next Next ReDim Preserve brr(1 To UBound(brr), 1 To UBound(arr, 2)) End If For i = lngHeadLine + 1 To UBound(arr) '遍历数据区域的行 k = k + 1 '累加记录条数 For j = 1 To UBound(arr, 2) '遍历列 brr(k, j) = "'" & arr(i, j) '全部转换为文本，避免数值变形 Next If k = DATA_MAXROW Then '如果数据到达结果数组的上限，则读入表格，腾出空间,以便装新的数据 Range("a1").Offset(lngHeadLine + n).Resize(k, UBound(brr, 2)) = brr n = n + DATA_MAXROW ReDim brr(1 To DATA_MAXROW, 1 To UBound(brr, 2)) k = 0 End If Next End If .Close False '关闭工作簿，不保存。 End With End If strWKName = Dir '同路径下的下一个excel工作簿 Loop If k > 0 Then Range("a1").Offset(lngHeadLine + n).Resize(k, UBound(brr, 2)) = brr MsgBox "汇总完成,一共汇总：" & lngShtCount & "张表。" End If Application.ScreenUpdating = True '恢复屏幕更新End Sub
…
小贴士：
该段代码只是汇总指定文件夹下每个工作簿的第一张工作表的数据，不要求每张分表列数一致，但要求字段名一致；下期我们会分享如何汇总指定文件夹下每个工作簿所有工作表或者表名包含某个关键词的代码——能一口气读完这段话我扶你过马路不怕讹~
爱我，一直。
|
|
转播
