如何使用VB代码实现数据的快速分类

majinxk001

我的原始数据时这样的，
希望通过代码 实现这样的效果

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
链接的字典案例。楼主可以参考。。。。。。

jiangxiaoyun

这是要做三级下拉菜单,然后过来这里找义工?

一指禅62

1. Sub 数据整理()
   
2.     Dim arr, i%, s$, d As Object
   
3.     Dim x%, x1%
   
4.     Rem  提取不重复值及其行号，保存到字典
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheet1.Range("A1").CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1) & "|" & arr(i, 2)
   
9.         If Not d.Exists(s) Then
   
10.             d(s) = i
    
11.             x1 = 1
    
12.         Else
    
13.             d.Item(s) = d.Item(s) & "|" & i
    
14.             x1 = x1 + 1
    
15.         End If
    
16.         x = IIf(x1 > x, x1, x)
    
17.     Next
    
18.     Rem  整理、缓存到数组
    
19.     ReDim a(0 To d.Count, 0 To x + 1)
    
20.     Dim k, t, m%, n%
    
21.     k = d.keys
    
22.     a(0, 0) = Split(k(0), "|")(0)
    
23.     For i = 0 To d.Count - 1
    
24.         m = m + 1: n = n + 1: x = 0
    
25.         a(0, n) = Split(k(i), "|")(1)
    
26.         a(m, 0) = Split(k(i), "|")(1)
    
27.         For Each t In Split(d.Item(k(i)), "|")
    
28.             x = x + 1
    
29.             a(m, x) = arr(Val(t), 3)
    
30.         Next
    
31.     Next
    
32.     Rem  输出到工作表区域
    
33.     Sheet1.Range("I15").Resize(UBound(a, 2) + 1, UBound(a) + 1) = WorksheetFunction.Transpose(a)
    
34. End Sub

复制代码

一指禅62

为测试，源数据中增加了内容，已异色标出。

数据整理.rar (15.92 KB, 下载次数: 15)

2020-1-18 20:12 上传

点击文件名下载附件

majinxk001

一指禅62 发表于 2020-1-18 20:09

非常感谢您的帮助，谢谢