如何多种数据形式的统计（补充）

aman1516

数据既有一定的规律性，也有多种形式，请教一下老师如何处理，然后按月度进行统计，详见附件： 如何按月统计数量.rar (17.17 KB, 下载次数: 18)

2017-7-30 14:18 上传

点击文件名下载附件

2017-8-5补充：
除了按月统计外，能否还能按同一月中带括弧（括弧不分中英文）的不同内容再分类统计，若是不带括弧的数据，则归到“无”这类中去：
见附图：

请各位老师再施绶手，如何处理字符串，谢谢！

qingc0221

字典+数组+正则表达式

qingc0221

1. Sub 汇总()
   
2.     Dim i As Long, j As Long    '循环变量
   
3.     Dim m As Integer, n As Integer, p As Integer    '定位变量
   
4.     Dim S As Double, Nums As Long    '面积、数量
   
5.     Dim Sht As Worksheet, d As Object, Re As Object, Mat As Object, Mats As Object
   
6.     Dim Data, Result()
   
7.     Set Sht = Sheets("汇总")
   
8.     Set Re = CreateObject("vbscript.regexp")
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Data = Sht.Range("A1").CurrentRegion
    
11.     For i = 2 To UBound(Data)
    
12.         S = 0: Nums = 0
    
13.         If Not d.exists(Data(i, 1)) Then
    
14.             n = n + 1
    
15.             d(Data(i, 1)) = n
    
16.             ReDim Preserve Result(1 To 3, 1 To n)
    
17.             Result(1, n) = Data(i, 1)
    
18.             m = n
    
19.         Else
    
20.             m = d(Data(i, 1))
    
21.         End If
    
22.         With Re
    
23.             .Global = True
    
24.             .Pattern = "[\d\*]+"
    
25.             Set Mats = .Execute(Data(i, 2))
    
26.             For Each Mat In Mats
    
27.                 S = S + Evaluate(Mat.Value) / 1000000
    
28.                 p = InStrRev(Mat.Value, "*")
    
29.                 Nums = Nums + Right(Mat.Value, Len(Mat.Value) - p)
    
30.             Next Mat
    
31.         End With
    
32.         Result(2, m) = Result(2, m) + Nums
    
33.         Result(3, m) = Result(3, m) + S
    
34.     Next i
    
35.     Range("A2").Resize(n, 3) = Application.Transpose(Result)
    
36. End Sub

复制代码

zax010

Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    ar = Sheet8.Range("A1").CurrentRegion
    For i = 2 To UBound(ar)
        ar(i, 2) = Replace(ar(i, 2), Chr(10), " ")
        s = Split(ar(i, 2), " ")
        For x = 0 To UBound(s)
            If s(x) <> "" Then
                ss = Split(s(x), "*")
                kk = Val(ss(0)) * Val(ss(1)) * Val(ss(2)) / 1000000
                d(ar(i, 1)) = d(ar(i, 1)) + kk
                d1(ar(i, 1)) = d1(ar(i, 1)) + Val(ss(2))
            End If
        Next
    Next
    With Sheet1
        For Each k In d.keys
            .Cells(2 + n, 1) = k: .Cells(2 + n, 2) = d1(k):: .Cells(2 + n, 3) = d(k)::
            n = n + 1
        Next
    End With
End Sub

zax010

如何按月统计数量.rar (22.1 KB, 下载次数: 15)

2017-7-30 15:54 上传

点击文件名下载附件

aman1516

非常感谢各位老师的指导，1月与4月跑出来的结果有偏差，用手工进行统计核对确认一下总数量：104和76是对的；

cbtaja

baigangliao 发表于 2017-7-30 15:58
月份        总数量        总平方
1月        104        103.448682
2月        38        36.927409

看了前面用 正则表达式+字典+数组的代码，我也来一个：

1. Sub sCount()
   
2. Dim dic, reg, arr, brr, mas, ma, r&, i&, p&, n&
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set reg = CreateObject("vbscript.regexp")
   
5. reg.Pattern = "\d+\*\d+\*(\d+)" '正则表达式尽可能精准，并用分组来获取其中的子项
   
6. reg.Global = True '尽可能在循 环外设置正则对 象属 性
   
7. arr = Sheet8.Range("A1").CurrentRegion.Resize(, 2)
   
8. r = UBound(arr): ReDim brr(1 To r, 1 To 3)
   
9. For i = 2 To r
   
10.     If dic.exists(arr(i, 1)) Then
    
11.         p = dic(arr(i, 1))
    
12.     Else
    
13.         n = n + 1: p = n
    
14.         brr(n, 1) = arr(i, 1)
    
15.         dic(arr(i, 1)) = p
    
16.     End If
    
17.     Set mas = reg.Execute(arr(i, 2))
    
18.     For Each ma In mas
    
19.         brr(p, 3) = brr(p, 3) + Evaluate(ma.Value) / 1000000
    
20.         brr(p, 2) = brr(p, 2) + Val(ma.submatches(0))
    
21.     Next
    
22. Next
    
23. Sheet1.UsedRange.Resize(, 3).Offset(1).ClearContents '清除原有结果
    
24. Sheet1.Range("A2").Resize(n, 3) = brr '填写当前统计结果
    
25. Sheet1.Activate
    
26. End Sub

复制代码

aman1516

cbtaja 发表于 2017-8-2 07:08
看了前面用 正则表达式+字典+数组的代码，我也来一个：

处理不规范数据，应该是正则更“兼容”些，学习学习

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.   With reg
   
8.     .Global = True
   
9.     .MultiLine = True
   
10.     .Pattern = "(\d+\*\d+)\*(\d+)"
    
11.   End With
    
12.   With Worksheets("汇总")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a2:b" & r)
    
15.     For i = 1 To UBound(arr)
    
16.       If Not d.exists(arr(i, 1)) Then
    
17.         ReDim brr(1 To 3)
    
18.         brr(1) = arr(i, 1)
    
19.       Else
    
20.         brr = d(arr(i, 1))
    
21.       End If
    
22.       Set mh = reg.Execute(arr(i, 2))
    
23.       For k = 0 To mh.Count - 1
    
24.         x = Application.Evaluate(mh(k).Value) / 1000000
    
25.         y = Val(mh(k).SubMatches(1))
    
26.         brr(3) = brr(3) + x
    
27.         brr(2) = brr(2) + y
    
28.       Next
    
29.       d(arr(i, 1)) = brr
    
30.     Next
    
31.   End With
    
32.   With Worksheets("统计")
    
33.     .Range("a2").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
    
34.   End With
    
35. End Sub
    

复制代码