求一个数组字典汇总，谢谢。

马小呆

请看附件，谢谢

马小呆

各位早上好。

cjc209

看不懂            

沈默00

需求很奇怪，数量分单表合计，次数又叠加

shiruiqiang

---------------------

编号有点不同

马小呆

沈默00 发表于 2023-12-9 09:44
需求很奇怪，数量分单表合计，次数又叠加

实际就是两个表去重合计件数和数量，然后合计两个表共同出现的次数。

最后把日期范围以外的补在最下面。

马小呆

cjc209 发表于 2023-12-9 09:28
看不懂

不好意思，语言表达能力有点差

3190496160

这个表格，设计的真是牛逼，代码写好测试才发现，表一和表二的结构都不一样的

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), cr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
ReDim br(1 To 100000, 1 To 9)
ReDim cr(1 To 100000, 1 To 9)
With Sheets("汇总")
    ks = .[c3]
    js = .[e3]
    lh = 1
    For Each sh In Sheets(Array("表1", "表2"))
        m = m + 1
        r = sh.Cells(Rows.Count, 2).End(xlUp).Row
        ar = sh.Range("b5:j" & r)
        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
                        t = d(ar(i, 2))
                        If t = "" Then
                            k = k + 1
                            d(ar(i, 2)) = k
                            t = k
                            br(k, 1) = k
                            br(k, lh + m) = ar(i, 2)
                            If sh.Name = "表1" Then
                                br(k, 4) = ar(i, 3)
                                br(k, 5) = ar(i, 4)
                                br(k, 6) = ar(i, 5)
                            Else
                                br(k, 4) = ar(i, 4)
                                br(k, 5) = ar(i, 6)
                                br(k, 6) = ar(i, 8)
                            End If
                        End If
                        If sh.Name = "表1" Then
                            br(t, lh + m + 5) = br(t, lh + m + 5) + ar(i, 6)
                        Else
                            br(t, lh + m + 5) = br(t, lh + m + 5) + ar(i, 9)
                        End If
                        br(t, 9) = br(t, 9) + 1
                    Else
                        tt = d(ar(i, 2))
                        If tt = "" Then
                            kk = kk + 1
                            dc(ar(i, 2)) = kk
                            tt = kk
                            cr(kk, 1) = kk
                            cr(kk, lh + m) = ar(i, 2)
                            If sh.Name = "表1" Then
                                cr(kk, 4) = ar(i, 3)
                                cr(kk, 5) = ar(i, 4)
                                cr(kk, 6) = ar(i, 5)
                            Else
                                cr(kk, 4) = ar(i, 4)
                                cr(kk, 5) = ar(i, 6)
                                cr(kk, 6) = ar(i, 8)
                            End If
                        End If
                        If sh.Name = "表1" Then
                            cr(tt, lh + m + 5) = cr(tt, lh + m + 5) + ar(i, 6)
                        Else
                            cr(tt, lh + m + 5) = cr(tt, lh + m + 5) + ar(i, 9)
                        End If
                        cr(tt, 9) = cr(tt, 9) + 1
                    End If
                End If
            End If
        Next i
        d.RemoveAll
        dc.RemoveAll
    Next sh
    .UsedRange.Offset(5) = Empty
    .[b6].Resize(k, UBound(br, 2)) = br
    .Cells(k + 7, 2).Resize(kk, UBound(cr, 2)) = cr
End With
MsgBox "ok!"
End Sub

3190496160

结果为核对，代码仅供参考
数组字典汇总.rar (37.58 KB, 下载次数: 18)

2023-12-9 10:38 上传

点击文件名下载附件