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

tgydslr

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

学习

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 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

复制代码