|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 一指禅62 于 2016-4-1 07:39 编辑
反复写有关数据汇总的文件，很费时。放一个在这儿，希望可以帮助需要的同学。
- Sub 一键汇总()
- Dim myPath$, f$, Wb As Workbook, Sh As Worksheet
- Dim d As Object, temp, arr(), n%, i%, x%, S$
- Dim k%, m As Double
- Set d = CreateObject("Scripting.Dictionary")
- myPath = ThisWorkbook.Path & ""
- f = Dir(myPath & "*.xls*")
- Do While f <> ""
- If f <> ThisWorkbook.Name Then
- Set Wb = Workbooks.Open(myPath & f)
- For Each Sh In Wb.Worksheets
- temp = Sh.UsedRange
- For i = 2 To UBound(temp)
- k = k + temp(i, 4) '数量累计
- m = m + temp(i, 8) '金额累计
- S = temp(i, 1) & "|" & temp(i, 2)
- If Not d.Exists(S) Then
- n = n + 1: ReDim Preserve arr(1 To 2, 1 To n)
- d(S) = n
- arr(1, n) = temp(i, 4) '数量
- arr(2, n) = temp(i, 8) '金额
- Else
- x = d.Item(S)
- arr(1, x) = arr(1, x) + temp(i, 4) '数量
- arr(2, x) = arr(2, x) + temp(i, 8) '金额
- End If
- Next
- Next
- Wb.Close False
- End If
- f = Dir
- Loop
- Application.ScreenUpdating = False
- Range("A2:H65536").Clear
- If n > 0 Then
- Range("A2").Resize(UBound(arr, 2), 2) = WorksheetFunction.Transpose(d.keys)
- Range("C2").Resize(UBound(arr, 2), 2) = WorksheetFunction.Transpose(arr)
- Range("A:A").Replace "|*", ""
- Range("B:B").Replace "*|", ""
- Range("B" & n + 2) = "合计"
- Range("C" & n + 2) = k
- Range("D" & n + 2) = m
- Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
- End If
- Application.ScreenUpdating = True
- Set Sh = Nothing
- Set Wb = Nothing
- Set d = Nothing
- End Sub
多工作簿汇总.rar
(19 KB, 下载次数: 758)
|
评分
-
1
查看全部评分
-
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2016-3-31 11:14
