[已解决]求助编号分组规则

ms967967

根据数据所描述的编号号段进行分组，求助如何编写VBA。
内容如楼下附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-1-5 13:50

1. Sub Macro1()
   
2. Dim arr, d, d2, i&, bm$
   
3. arr = Range("g2").CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. Const n = 20
   
7. For i = 1 To n
   
8.     bm = "aa" & Format(i, "000")
   
9.     d(bm) = 1 + (i - 1) \ 5
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     x = Split(arr(i, 1), "-")
    
13.     For j = Right(x(0), 3) To Right(x(1), 3)
    
14.         bm = "aa" & Format(j, "000")
    
15.         d2(d(bm)) = d2(d(bm)) + 1
    
16.     Next
    
17.     a = d2.keys: b = d2.items
    
18.     If d2.Count = 1 Then arr(i, 3) = a(0)
    
19.     If d2.Count = 2 Then arr(i, 3) = IIf(b(1) >= b(0), a(1), a(0))
    
20.     If d2.Count = 3 Then arr(i, 3) = a(1)
    
21.     d2.RemoveAll
    
22. Next
    
23. Range("K2").Resize(UBound(arr)) = Application.Index(arr, 0, 3)
    
24. End Sub

复制代码

跳转到最佳答案楼层

ms967967

分组.rar (8.31 KB, 下载次数: 15)

2014-12-30 20:55 上传

点击文件名下载附件

grf1973

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Range("c3:d" & [d65536].End(3).Row)
   
4.     For i = 1 To UBound(arr)
   
5.         If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
6.         d(arr(i, 2)) = arr(i, 1)       '编号为key，组别为item
   
7.     Next
   
8.    
   
9.     Set d1 = CreateObject("scripting.dictionary")
   
10.     brr = [g2:i6]
    
11.     For i = 2 To UBound(brr)
    
12.         x = Split(brr(i, 1), "-")
    
13.         a1 = Val(Right(x(0), 3)): a2 = Val(Right(x(1), 3))      '首编号、尾编号
    
14.         brr(i, 2) = a2 - a1 + 1    '数量
    
15.         For k = a1 To a2
    
16.             xk = "aa" & Format(k, "000")     '编号
    
17.             tk = d(xk)      '编号对应第几组
    
18.             d1(tk) = d1(tk) + 1        '第几组的个数
    
19.         Next
    
20.         dk = d1.keys: dt = d1.items
    
21.         imax = Application.Max(dt)        '个数中最多者
    
22.         ip = Application.WorksheetFunction.Match(imax, dt)       '最多者在数组中的位置（从1开始，如果相等取后者）
    
23.         brr(i, 3) = dk(ip - 1)       '对应的组别（从0开始）
    
24.         d1.RemoveAll
    
25.     Next
    
26.     [g2:i6] = brr
    
27. End Sub

复制代码

grf1973

请看附件。

ms967967

grf1973 发表于 2014-12-31 15:50
请看附件。

感谢您的帮助，如果实际应用表中没有C:D列的内容，是否有办法做到想要的结果。

dsmch

1. Sub Macro1()
   
2. Dim arr, d, d2,i&,bm$
   
3. arr = Range("g2").CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. Const n = 20
   
7. For i = 1 To n
   
8.     bm = "aa" & Format(i, "000")
   
9.     d(bm) = 1 + (i - 1) \ 5
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     x = Split(arr(i, 1), "-")
    
13.     For j = Right(x(0), 3) To Right(x(1), 3)
    
14.         bm = "aa" & Format(j, "000")
    
15.         d2(d(bm)) = d2(d(bm)) + 1
    
16.     Next
    
17.     a = d2.keys: b = d2.items
    
18.     If d2.Count = 1 Then
    
19.         arr(i, 3) = a(0)
    
20.     Else
    
21.         arr(i, 3) = IIf(b(1) >= b(0), a(1), a(0))
    
22.     End If
    
23.     d2.RemoveAll
    
24. Next
    
25. Range("K2").Resize(UBound(arr)) = Application.Index(arr, 0, 3)
    
26. End Sub

复制代码

ms967967

感谢您一次次的帮助

ms967967

dsmch 发表于 2015-1-3 16:52

如果描述是aa004-aa013要得到的分组是2，应怎么加语句

ms967967

分组.rar (21.12 KB, 下载次数: 2)

2015-1-4 18:29 上传

点击文件名下载附件
感谢dsmch老师的帮助。当有如下条件要求时怎么增加语句，请指教。
描述的编号范围最多为15个（3组），
　　　当只有两组时，分组显示较多的组号
　　　当两组一样多时，分组显示最大的组号
　　　当有三组时，只显示中间的组号

ms967967

dsmch 发表于 2015-1-3 16:52

重新上传附件，再次请您支持