汇总多个工作簿首个工作表的数据到总表

  • A+
所属分类:好好学习

汇总指定文件夹下每个工作簿的第一张工作表的数据,且限定了汇总后最大行数为20万行:

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

 

发表评论

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: