取不重复值

42921783

A、A列是不同编号的明细，其中一些行的编号用+连接，两个编号用1个+连接，N+1个编号用N个+连接；

B、主编号=编号前10位；

需要求出主编号的不重复值，如何用VBA解决。手动分列、函数再透视表等方法过程较为繁琐，请用VBA一步完成填充到E列。

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:a" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       brr = Split(arr(i, 1), "+")
    
11.       For j = 0 To UBound(brr)
    
12.         xm = Left(brr(j), 10)
    
13.         d(xm) = ""
    
14.       Next
    
15.     Next
    
16.     .Range("e2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
17.   End With
    
18. End Sub
    

复制代码

chxw68

很简单的问题。

duquancai

手机上网，看不了附件，编号前10位，如果这编号没有10位呢？

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arA = [a1].CurrentRegion
   
4.     For i = 2 To UBound(arA)
   
5.         arB = Split(arA(i, 1), "+")
   
6.         For k = 0 To UBound(arB)
   
7.             s = Left(arB(k), 10)
   
8.             d(s) = ""
   
9.         Next
   
10.     Next
    
11.     [e2].Resize(d.Count) = Application.Transpose(d.Keys)
    
12. End Sub

复制代码

duquancai

1. Sub main()
   
2.     Dim arr, js As Object, j$, t
   
3.     arr = Range("a2:a" & [a65535].End(3).Row)
   
4.     If Not IsArray(arr) Then Exit Sub
   
5.     Set js = CreateObject("MSScriptControl.ScriptControl")
   
6.     js.Language = "JavaScript": [e2:e1000].Clear
   
7.     js.AddCode "function f(a){return new VBArray(a).toArray();};re=/ /.compile(/[^+]+/g);"
   
8.     js.AddObject "a", js.CodeObject.f(arr)
   
9.     j = "b=[],o={};a.join('+').replace(re,function(s){if(s.length>9)o[s.substr(0,10)]=0;});"
   
10.     j = j & "for(k in o)b.push(k);": t = Split(js.eval(j & "b;"), ",")
    
11.     If UBound(t) >= 0 Then [e2].Resize(UBound(t) + 1) = Application.Transpose(t)
    
12. End Sub

复制代码

42921783

lsc900707 发表于 2018-9-18 19:13

这个会漏一些编号啊

lsc900707

42921783 发表于 2018-9-19 13:59
这个会漏一些编号啊

被你的第二点迷惑了，呵呵。没有分列出来。原帖代码已修改。