按起始终止日期多条件汇总

xkzb

1.根据数量汇总表起始日期D1单元格和截至日期F1单元格，汇总数据库这个时间段，按条件1.产地，2.出入库，3销售类别，统计数据库[数量]字段的总和
2.请给个VBA代码
3.同理销售汇总表要求也是如此
谢谢

3190496160

一个字典嵌套匹配累计的问题，先留个记号吧，今晚没人做的话，明天早上写一下吧

shiruiqiang

小计后面lz要表达啥，还不明确

shiruiqiang

销售总额就是多了一个条件“出库”

xkzb

shiruiqiang 发表于 2025-3-26 21:30
小计后面lz要表达啥，还不明确

谢谢，解答：统计跟上面一样

xkzb

shiruiqiang 发表于 2025-3-26 21:37
销售总额就是多了一个条件“出库”

老师，这是对的，汇总起来就行，最后能加一个总计最好

shiruiqiang

看在送花的份上

xkzb

shiruiqiang 发表于 2025-3-26 22:14
看在送花的份上

谢谢老师，很好，总计是我没说清楚，总计也分，出库，入库分别统计，能改一下更好，多谢老师

shiruiqiang

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim rr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("数据库")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
    If r < 2 Then MsgBox "数据库工作表为空，请先导入数据！": End
   ar = .Range("a1:q" & r)
End With
ReDim rr(1 To UBound(ar))
m = 1
rr(m) = 3
With Sheets("数量汇总")
    .UsedRange.Offset(3).Borders.LineStyle = 0
    .UsedRange.Offset(3) = Empty
    br = .Range("a3:j" & r)
    ks = .[d1]
    js = .[f1]
    For i = 2 To UBound(ar)
        If ar(i, 2) <> "" Then
            If IsDate(ar(i, 2)) Then
                If ar(i, 2) >= ks And ar(i, 2) <= js Then
                    If ar(i, 4) <> "" Then
                        s1 = ar(i, 4)
                        s2 = ar(i, 5)
                        s3 = ar(i, 6)
                        s4 = ar(i, 7)
                        If Not d.exists(s1) Then Set d(s1) = CreateObject("scripting.dictionary")
                        If Not d(s1).exists(s2) Then Set d(s1)(s2) = CreateObject("scripting.dictionary")
                        If Not d(s1)(s2).exists(s3) Then Set d(s1)(s2)(s3) = CreateObject("scripting.dictionary")
                        d(s1)(s2)(s3)(s4) = d(s1)(s2)(s3)(s4) + ar(i, 8)
                    End If
                End If
            End If
        End If
    Next i
    For j = 5 To UBound(br, 2)
        dc(br(1, j)) = j
    Next j
    n = 1
    For Each k In d.keys
        For Each kk In d(k).keys
            For Each kkk In d(k)(kk).keys
                n = n + 1
                br(n, 2) = k
                br(n, 3) = kk
                br(n, 4) = kkk
                For Each kkkk In d(k)(kk)(kkk).keys
                    lh = dc(kkkk)
                    br(n, lh) = d(k)(kk)(kkk)(kkkk)
                Next kkkk
            Next kkk
            n = n + 1
            br(n, 1) = "小计"
            m = m + 1
            rr(m) = n + 2
        Next kk
    Next k
    n = n + 2
    br(n - 1, 1) = "入库总计"
    br(n, 1) = "出库总计"
    .[a3].Resize(n, UBound(br, 2)) = br
    .[a3].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
    w = n + 2
    For i = 2 To m
        ks = rr(i - 1) + 1
        js = rr(i) - 1
        For j = 5 To UBound(br, 2)
            .Cells(js + 1, j) = Application.Sum(.Range(.Cells(ks, j), .Cells(js, j)))
            If .Cells(js - 1, 3) = "入库" Then .Cells(w - 1, j) = .Cells(w - 1, j) + .Cells(js + 1, j)
            If .Cells(js - 1, 3) = "出库" Then .Cells(w, j) = .Cells(w, j) + .Cells(js + 1, j)
        Next j
    Next i
End With
Set d = Nothing
Set dc = Nothing
MsgBox "ok!"
End Sub