请教如何将类目通过VBA进行分类

丶Tnn

请教各位高手.

如附件.

如何通过VBA实现.
根据将对应主题的大类都归结到B列里面. 并统计数量和


ceshi.rar (169.13 KB, 下载次数: 18)

2015-5-11 13:56 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("数据库")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:c" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
14.         ReDim brr(1 To 3)
    
15.         brr(1) = arr(i, 1)
    
16.         brr(2) = arr(i, 2)
    
17.       Else
    
18.         brr = d(arr(i, 1))(arr(i, 2))
    
19.       End If
    
20.       brr(3) = brr(3) + arr(i, 3)
    
21.       d(arr(i, 1))(arr(i, 2)) = brr
    
22.     Next
    
23.   End With
    
24.   With Worksheets("展示表")
    
25.     .UsedRange.Offset(2, 0).Clear
    
26.     r = 2
    
27.     For Each aa In d.keys
    
28.       For Each bb In d(aa).keys
    
29.         r = r + 1
    
30.         .Cells(r, 1).Resize(1, 3) = d(aa)(bb)
    
31.       Next
    
32.     Next
    
33.   End With
    
34. End Sub
    

复制代码

chxw68

没太看懂楼主意思，猜着做的，不知道对不对。

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, i&, x$, y$, k, t, kk, tt, d, j&, n&
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Sheet2.Activate
   
5.     [a3:c500].ClearContents
   
6.     Arr = Sheet1.[a1].CurrentRegion
   
7.     For i = 2 To UBound(Arr)
   
8.         x = Arr(i, 1): y = Arr(i, 2)
   
9.         If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
   
10.         d(x)(y) = d(x)(y) + Arr(i, 3) '
    
11.     Next
    
12.     k = d.keys: t = d.items: n = 2
    
13.     For i = 0 To UBound(k)
    
14.         kk = t(i).keys: tt = t(i).items
    
15.         For j = 0 To UBound(kk)
    
16.             n = n + 1
    
17.             Cells(n, 1) = k(i): Cells(n, 2) = kk(j): Cells(n, 3) = tt(j)
    
18.         Next
    
19.     Next
    
20. End Sub
    

复制代码

丶Tnn

chxw68 发表于 2015-5-11 14:47
没太看懂楼主意思，猜着做的，不知道对不对。

太感谢您了,  和我想表达的差不多.

就是您的太高级了点 .    我只想要 大类和数量归集就可以了.  

主题这一列 ,就是 图中红色的地方不能动.  要如何改?

蓝桥玄霜

请见附件。

丶Tnn

蓝桥玄霜 发表于 2015-5-11 14:53

谢谢您的回复, 是我上面没表达清楚.   

您告诉的能把前面汇总起来.

因为有一列是不能动的.  (主题列是预先放置在展示表中了的.)

您的代码需要如何调整?

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim Arr, i&, x$, y$, k, t, kk, tt, d, j&, n&, r1, m&
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Sheet2.Activate
   
5.     [b3:c500].ClearContents
   
6.     Arr = Sheet1.[a1].CurrentRegion
   
7.     For i = 2 To UBound(Arr)
   
8.         x = Arr(i, 1): y = Arr(i, 2)
   
9.         If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
   
10.         d(x)(y) = d(x)(y) + Arr(i, 3) '
    
11.     Next
    
12.     k = d.keys: t = d.items
    
13.     For i = 0 To UBound(k)
    
14.         Set r1 = [a:a].Find(k(i), , , 1)
    
15.         m = r1.Row
    
16.         kk = t(i).keys: tt = t(i).items
    
17.         For j = 0 To UBound(kk)
    
18.             n = m + j
    
19.             Cells(n, 2) = kk(j): Cells(n, 3) = tt(j)
    
20.         Next
    
21.     Next
    
22. End Sub
    

复制代码

丶Tnn

蓝桥玄霜 发表于 2015-5-12 09:50

太感谢老师了.  
一大早就回复了我的问题.

还有两个小问题.
在主题列如果我预先未设置 会出现报错.
以及主题列主题设置不足时,会造成在行没有对应主题的时候,大类列仍然会提取大类.

不过不是特别碍事,我自己操作的时候提前注意即可.

yjh_27

丶Tnn 发表于 2015-5-12 10:22
太感谢老师了.  
一大早就回复了我的问题.

需统计主题内容及顺序在k列自定义