|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub test()
Dim i, j, k, m, n As Integer
Dim kk
Dim ar, br, cr, dr, er As Variant
Dim d1, d2, d3, d4 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
If Sheets("数据库").AutoFilterMode Then
Sheets("数据库").AutoFilterMode = False
End If
ar = Sheets("数据库").UsedRange
ReDim br(1 To UBound(ar), 1 To 4)
For i = 2 To UBound(ar)
If ar(i, 2) >= Sheets("数量汇总").[d1] And ar(i, 2) <= Sheets("数量汇总").[f1] Then
d1(ar(i, 4) & ar(i, 5)) = ""
d2(ar(i, 4) & ar(i, 5) & ar(i, 6) & ar(i, 7)) = ar(i, 8) + d2(ar(i, 4) & ar(i, 5) & ar(i, 6) & ar(i, 7))
d3(ar(i, 4) & ar(i, 5) & ar(i, 7)) = d3(ar(i, 4) & ar(i, 5) & ar(i, 7)) + ar(i, 8)
If Not d4.exists(ar(i, 4) & ar(i, 5) & ar(i, 6)) Then
m = m + 1: d4(ar(i, 4) & ar(i, 5) & ar(i, 6)) = ""
For j = 2 To 4
br(m, j) = ar(i, j + 2)
Next
End If
End If
Next
Sheets("数量汇总").[m1].Resize(m, 4) = br
ReDim cr(1 To m * 2, 1 To 4)
For Each kk In d1.keys
For i = 1 To m
If br(i, 2) & br(i, 3) = kk Then
n = n + 1
For j = 1 To 4
cr(n, j) = br(i, j)
Next
End If
Next
n = n + 1
cr(n, 1) = "小计": cr(n, 3) = cr(n - 1, 3)
Next
Sheets("数量汇总").[a5].Resize(n, 4) = cr
dr = Sheets("数量汇总").Range("a1:j" & Sheets("数量汇总").[c65536].End(xlUp).Row)
ReDim er(1 To n, 1 To UBound(dr, 2) - 4)
For i = 5 To UBound(dr)
If dr(i, 2) <> "" Then
For j = 5 To UBound(dr, 2)
er(i - 4, j - 4) = d2(dr(i, 2) & dr(i, 3) & dr(i, 4) & dr(4, j))
Next
Else
For j = 5 To UBound(dr, 2)
er(i - 4, j - 4) = d3(dr(i - 1, 2) & dr(i, 3) & dr(4, j))
Next
End If
Next
Sheets("数量汇总").[e5].Resize(UBound(er), UBound(er, 2)) = er
MsgBox "ok"
End Sub
|
|
楼主: xkzb
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2025-3-27 08:39
楼主
