[已解决]用VBA统计数据，新手请教

sf033806

用VBA统计数据，能统计出单个产品的数量，谢谢了

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-4-7 14:46

新建 Microsoft Excel 工作表.rar (11.9 KB, 下载次数: 15)

2014-4-7 14:46 上传

点击文件名下载附件

跳转到最佳答案楼层

开心妙妙

坐等高手解题学习

hwc2ycy

1. Sub test()
   
2.     Dim arr, i&
   
3.     arr = Range("a1").CurrentRegion
   
4.     Dim objRegExp As Object
   
5.     Dim str$, obj As Object
   
6.     Dim dic As Object, lCount%
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     dic.Add "产品", "数量"
   
9.     str = "aaa((80) bbb(10) ccc(10)"
   
10.     Set objRegExp = CreateObject("VBScript.regExp")
    
11.     With objRegExp
    
12.         .Global = True
    
13.         .Pattern = "([\u4e00-\u9fa5]+)[ (]{0,}(\d+)"
    
14.         For i = 1 To UBound(arr)
    
15.             If .test(arr(i, 1)) Then
    
16.                 For Each obj In .Execute(arr(i, 1))
    
17.                 str = obj.submatches(0): lCount = obj.submatches(1)
    
18.                     dic(str) = dic(str) + lCount
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.     End With
    
23.     Set objRegExp = Nothing
    
24.     Columns("c:d").ClearContents
    
25.     Range("c1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    
26.     Range("d1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
    
27.     MsgBox "统计完成"
    
28. End Sub
    

复制代码

hwc2ycy

数量不知道对不对，验证就麻烦楼主了。

ghostjiao

1. Sub 提取()
   
2.     Dim arr, i%, n&, m%, Z&, brr(1 To 1000, 1 To 1), CRR(), reg As Object, matches As Object, dic As Object
   
3.     arr = Range(Range("a1"), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
   
4.     Set reg = CreateObject("vbscript.regexp")
   
5.     For i = 1 To UBound(arr)
   
6.         With reg
   
7.             .Global = True
   
8.             .Pattern = "[A-Z]?[\u4e00-\u9fa5]{2,}|\d+"
   
9.             Set matches = .Execute(arr(i, 1))
   
10.             For Each Match In matches
    
11.                 n = n + 1
    
12.                 brr(n, 1) = Match
    
13.             Next
    
14.         End With
    
15.     Next
    
16.     ReDim CRR(1 To n / 2, 1 To 2)
    
17.     For Z = 1 To n Step 2
    
18.         m = m + 1
    
19.         CRR(m, 1) = brr(Z, 1)
    
20.         CRR(m, 2) = brr(Z + 1, 1)
    
21.     Next
    
22.     Set dic = CreateObject("scripting.dictionary")
    
23.     For m = 1 To UBound(CRR)
    
24.         dic(CRR(m, 1)) = dic(CRR(m, 1)) + Val(CRR(m, 2))
    
25.     Next
    
26.     Range("h13").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
27.     Range("i13").Resize(dic.Count, 1) = Application.Transpose(dic.items)
    
28.     End Sub
    

复制代码

我就是打个酱油，向烟花版主学习

hwc2ycy

1. Sub test()
   
2.     Dim arr, i&
   
3.     Dim objRegExp As Object
   
4.     Dim str$, obj As Object
   
5.     Dim dic As Object, lCount%
   
6.     arr = Range("a1").CurrentRegion
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     dic.Add "产品", "数量"
   
9.     Set objRegExp = CreateObject("VBScript.regExp")
   
10.     With objRegExp
    
11.         .Global = True
    
12.         .Pattern = "([a-zA-Z]*[\u4e00-\u9fa5]+)[ (]{0,}(\d+)"
    
13.         For i = 1 To UBound(arr)
    
14.             If .test(arr(i, 1)) Then
    
15.                 For Each obj In .Execute(arr(i, 1))
    
16.                 str = obj.submatches(0): lCount = obj.submatches(1)
    
17.                     dic(str) = dic(str) + lCount
    
18.                 Next
    
19.             End If
    
20.         Next
    
21.     End With
    
22.     Set objRegExp = Nothing
    
23.     Columns("c:d").ClearContents
    
24.     Range("c1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.keys)
    
25.     Range("d1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
    
26.     Set dic = Nothing
    
27.     MsgBox "统计完成"
    
28. End Sub

复制代码

有个带T的给漏了，改下。

sf033806

hwc2ycy 发表于 2014-4-7 13:51
有个带T的给漏了，改下。

牛人，小的以前没有用过VBA麻烦能给做个模板吧，太谢谢了

hwc2ycy

新建 Microsoft Excel 工作表.rar (11.9 KB, 下载次数: 15)

2014-4-7 14:46 上传

点击文件名下载附件