数据去重重排

海天酱油

数据去重重排.zip (10.25 KB, 下载次数: 24)

2014-6-2 17:46 上传

点击文件名下载附件

百度不到去谷歌

2次字典去重 也可以首先对整行去重了做A列去重就行

1. Sub 去重重排() '字典用法一
   
2.     Dim i&, j&, arr, brr, dic1, dic2
   
3.     arr = Range([A1], [b65536].End(xlUp)) 'AB列
   
4.     Set dic1 = CreateObject("scripting.dictionary")
   
5. '--先取得A列关键字对应项
   
6.     For i = 1 To UBound(arr)
   
7.         If dic1.exists(arr(i, 1)) Then '字典中已存在则条目累计
   
8.             dic1(arr(i, 1)) = dic1(arr(i, 1)) & "," & arr(i, 2)
   
9.         Else
   
10.             dic1(arr(i, 1)) = arr(i, 2) '字典中不存在加入
    
11.         End If
    
12.     Next
    
13. '--对A列关键字的B列项目去重
    
14.     arr = dic1.keys
    
15.     Set dic2 = CreateObject("scripting.dictionary")
    
16.     For i = 0 To UBound(arr)
    
17.         brr = Split(dic1(arr(i)), ",") '取出A关键字对应项目
    
18.         For j = 0 To UBound(brr) 'B列子项去重
    
19.             If Not dic2.exists(brr(j)) Then dic2(brr(j)) = brr(j)
    
20.         Next
    
21.         dic1(arr(i)) = Join(dic2.keys, ",") '去重重组
    
22.         dic2.RemoveAll
    
23.     Next
    
24.     [E:F] = ""
    
25.     [E1].Resize(dic1.Count) = Application.Transpose(dic1.keys)   '导出关键字
    
26.     [F1].Resize(dic1.Count) = Application.Transpose(dic1.items)  '导出条目
    
27. End Sub

复制代码

数据去重重排.zip (15.89 KB, 下载次数: 21)

2014-6-2 18:09 上传

点击文件名下载附件

海天酱油

百度不到去谷歌 发表于 2014-6-2 18:09
2次字典去重 也可以首先对整行去重了做A列去重就行

我就是不会去重的处理
多谢了！

bluexuemei

1. 
   
2. Sub t()
   
3. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
4. ojs.eval ("def aa(aa) $aa=aa end")
   
5. y = ojs.Run("aa", Range("a1", [b1].End(4)).Value)
   
6. y = ojs.eval("h={};$aa.each{|x|(h[x[0]]||=[])<<x[1].to_i};h.map{|k,v|[k,v.uniq.join(',')]}")
   
7. [c1].Resize(UBound(y) + 1, UBound(y, 2) + 1) = y
   
8. 'Stop
   
9. End Sub

复制代码

zax010

Sub zz()
    Dim d, arr
    Set d = CreateObject("Scripting.Dictionary")
    arr = Sheet1.Range("A1:B" & Sheet1.Range("A1048576").End(xlUp).Row)
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            d(arr(i, 1)) = arr(i, 2)
        Else
            If InStr(d(arr(i, 1)), arr(i, 2)) = 0 Then
                d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
            End If
        End If
    Next
    Sheet1.Range("E1").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

zax010

。。。。。。。。。。


数据去重重排.rar (13.3 KB, 下载次数: 14)

2014-6-2 20:35 上传

点击文件名下载附件

大灰狼1976

zax010同学的instr用得确实巧妙，但是有必要提一下，如果B列并不是只有一位数的话，出错的几率是极大的。
好像暂时没人提议用字典嵌套来做，我就做了一个，附件请测试

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, d As Object, c, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1:b" & [a65536].End(3).Row)
   
5. For i = 1 To UBound(arr)
   
6.   If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
   
7.   d(arr(i, 1))(arr(i, 2)) = ""
   
8. Next i
   
9. ReDim arr(1 To d.Count, 1 To 2)
   
10. For Each c In d.keys
    
11.   r = r + 1
    
12.   arr(r, 1) = c
    
13.   arr(r, 2) = Join(d(c).keys, ",")
    
14. Next c
    
15. [c1].Resize(d.Count, 2) = arr
    
16. End Sub

复制代码

zax010

大灰狼1976 发表于 2014-6-2 20:53
zax010同学的instr用得确实巧妙，但是有必要提一下，如果B列并不是只有一位数的话，出错的几率是极大的。
...

谢谢提醒，这个题目用Instr是不很恰当。换个方式吧：
Sub zzz()
    Dim d, d1, arr
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    arr = Sheet1.Range("A1:B" & Sheet1.Range("A1048576").End(xlUp).Row)
    For i = 1 To UBound(arr)
        d(arr(i, 1) & "," & arr(i, 2)) = ""
        d1(arr(i, 1)) = ""
    Next
    For Each k In d1.keys
        s = Filter(d.keys, k)
        For i = 0 To UBound(s)
            ss = ss & "," & Split(s(i), ",")(1)
        Next
        Sheet1.Cells(1 + m, 3) = k
        Sheet1.Cells(1 + m, 4) = Mid(ss, 2)
        ss = "": m = m + 1
    Next
End Sub

百度不到去谷歌

大灰狼1976 发表于 2014-6-2 20:53
zax010同学的instr用得确实巧妙，但是有必要提一下，如果B列并不是只有一位数的话，出错的几率是极大的。
...

字典嵌套每个关键字都要创建一个新字典 多少个关键字就需要多少个字典 数据多的话效率就低了
我采取2次字典的意思就是第二次用字典时一次也只用一个 这样每次内存中都最多只存在2个字典

Zamyi

1. Sub test()
   
2. Dim w() As Boolean
   
3. Set d = CreateObject("scripting.dictionary")
   
4. r = Range("b1", [a65536].End(3))
   
5. ReDim w(1 To UBound(r))
   
6. For i = 1 To UBound(r)
   
7.   s = r(i, 1) & r(i, 2)
   
8.   If Not d.exists(s) Then d(s) = "": w(i) = True
   
9. Next
   
10. d.RemoveAll
    
11. For i = 1 To UBound(r)
    
12.   If w(i) Then
    
13.     If d(r(i, 1)) Then
    
14.       m = d(r(i, 1))
    
15.       r(m, 2) = r(m, 2) & "," & r(i, 2)
    
16.       Else
    
17.       n = n + 1
    
18.       d(r(i, 1)) = n
    
19.       r(n, 1) = r(i, 1)
    
20.       r(n, 2) = r(i, 2)
    
21.     End If
    
22.   End If
    
23. Next
    
24. [c1].Resize(n, 2) = r
    
25. End Sub

复制代码