VBA分类统计

coden0906

明细表如下：


可否完成按以下的日期统计


样表详见附件

1、可否用函数实现？
2、如果用VBA，后期数据量大的话，是否会影响运行速度？或者应该如何优化？
样表.zip (9.07 KB, 下载次数: 17)

2018-6-14 19:37 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Dim reg As New RegExp
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   With reg
   
9.     .Global = True
   
10.     .Pattern = "([^\*\+]+)\*?(\d+)?"
    
11.   End With
    
12.   With Worksheets("清单表")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a2:c" & r)
    
15.   End With
    
16.   n = 1
    
17.   For i = 1 To UBound(arr)
    
18.     If Not d.exists(arr(i, 1)) Then
    
19.       ReDim brr(1 To 100)
    
20.       brr(1) = arr(i, 1)
    
21.     Else
    
22.       brr = d(arr(i, 1))
    
23.     End If
    
24.     Set mh = reg.Execute(arr(i, 3))
    
25.     For j = 0 To mh.Count - 1
    
26.       xm = mh(j).SubMatches(0)
    
27.       sl = Val(mh(j).SubMatches(1))
    
28.       If Not d1.exists(xm) Then
    
29.         n = n + 1
    
30.         d1(xm) = n
    
31.       End If
    
32.       brr(d1(xm)) = brr(d1(xm)) + 1
    
33.     Next
    
34.     d(arr(i, 1)) = brr
    
35.   Next
    
36.   With Worksheets("汇总表")
    
37.     .Cells.Clear
    
38.     .Range("a1") = "日期"
    
39.     .Range("b1").Resize(1, d1.Count) = d1.keys
    
40.     .Range("a2").Resize(d.Count, 1 + d1.Count) = Application.Transpose(Application.Transpose(d.items))
    
41.     With .Range("a1").Resize(d.Count + 1, d1.Count + 1)
    
42.       .Borders.LineStyle = xlContinuous
    
43.     End With
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。

hopeson2010

1. Sub ek_sky()
   
2.    Dim arr As Variant, brr As Variant, crr As Variant
   
3.    Dim dis As Object
   
4.    Dim i As Integer, j As Integer, k As Integer, L As Integer, M As Integer
   
5.    Set dis = CreateObject("scripting.dictionary")
   
6.       With Sheets("清单表")
   
7.          arr = .Range("A2:C" & .Cells(.Rows.Count, 1).End(xlUp).Row)
   
8.       End With
   
9.       ReDim brr(1 To UBound(arr), 1 To 200)
   
10.       brr(1, 1) = "日期"
    
11.       k = 1: M = 1
    
12.       For i = 1 To UBound(arr)
    
13.          If Not dis.exists(arr(i, 1)) Then
    
14.            k = k + 1
    
15.          dis.Add arr(i, 1), k
    
16.          brr(k, 1) = arr(i, 1)
    
17.          End If
    
18.          crr = Split(arr(i, 3), "+")
    
19.          For L = 0 To UBound(crr)
    
20.             t = Left(crr(L), InStr(crr(L) & "*", "*") - 1)
    
21.             If Not dis.exists(t) Then
    
22.                 M = M + 1
    
23.                 dis.Add t, M
    
24.                 brr(1, M) = t
    
25.                 brr(dis(arr(i, 1)), M) = Val(Mid(crr(L) & "*", InStr(crr(L) & "*", "*") + 1, 15))
    
26.             Else
    
27.                brr(dis(arr(i, 1)), dis(t)) = brr(dis(arr(i, 1)), dis(t)) + Val(Mid(crr(L) & "*", InStr(crr(L) & "*", "*") + 1, 15))
    
28.             End If
    
29.          Next L
    
30.       Next i
    
31.       With Sheets("汇总表")
    
32.         .Range("A1").Resize(k, M) = brr
    
33.       End With
    
34. End Sub
    

复制代码

coden0906

chxw68 发表于 2018-6-14 20:00
详见附件。

大神好，就一个问题，* 后的代表数量，你统计表的结果，没有算上* 后面2 3 的这种。。。不知应该如何修改。。。。

humanmagic

coden0906 发表于 2018-6-18 19:07
大神好，就一个问题，* 后的代表数量，你统计表的结果，没有算上* 后面2 3 的这种。。。不知应该如何修改 ...

split()方法把c列按+分，然后循环遍历处理

chxw68

修改好了。

coden0906

chxw68 发表于 2018-6-18 22:00
修改好了。

大大好，如果我其中一张表上标明了每种奖品的价格，在明细表的奖品后一列加入价值，可以统计到每一个客户对应的奖品价值么？用你的VBA字典的方法。。。谢谢大大。。。

jygzcj

好多大神呀！