字典去重复问题

凌空一羽

Sub ipjp()
Dim arr As Variant, brr As Variant, i As Byte, j As Byte
Set d = CreateObject("Scripting.Dictionary")
arr = Range("a1").CurrentRegion
brr = Range("c1").CurrentRegion
For i = 2 To UBound(arr)
    For j = 2 To UBound(brr)
        If Not arr(i, 1) = brr(j, 1) Then d(arr(i, 1)) = ""
    Next
Next
Range("e2").Resize(d.Count, 1) = Application.Transpose(d.keys)
Set d = Nothing
End Sub


我想A列内容根据C列内容去除后，在E列得出结果，可是结果不对，是不是字典不能这样写呢？
请各位大侠帮忙解答一下，谢谢！

liulang0808

Sub ipjp()
Dim arr As Variant, brr As Variant, i As Byte, j As Byte
Set d = CreateObject("Scripting.Dictionary")
arr = Range("a1").CurrentRegion
brr = Range("c1").CurrentRegion
For i = 2 To UBound(arr)
    d(arr(i, 1)) = ""
   
Next
For j = 2 To UBound(brr)
    If d.exists(brr(j, 1)) Then
        d.Remove brr(j, 1)
    End If
Next
Range("e2").Resize(d.Count, 1) = Application.Transpose(d.keys)
Set d = Nothing
End Sub

liulang0808

附件内容供参考。。。。。。

wzsy2_mrf

1. Sub ipjp()
   
2.     Dim arr, brr, i&
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Range("a1").CurrentRegion
   
5.     brr = Range("c1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 1)) = "a"
   
8.     Next
   
9.     For i = 2 To UBound(brr)
   
10.         d(brr(i, 1)) = "b"
    
11.     Next
    
12.     i = 0
    
13.     ReDim brr(1 To 1)
    
14.     For Each mkey In d.keys
    
15.         If d(mkey) = "a" Then
    
16.             i = i + 1
    
17.             ReDim Preserve brr(1 To i)
    
18.             brr(i) = mkey
    
19.         End If
    
20.     Next
    
21.     Range("e2").Resize(UBound(brr), 1) = Application.Transpose(brr)
    
22.     Set d = Nothing
    
23. End Sub
    

复制代码

wzsy2_mrf

原程序没有发挥字典的效率，还在循环对比，且循环对比的程序也没有写对。

tyxvba7529

相当于arr的每一个与brr的每一个对比不同的，写入字典， 当然有A<>C的时候， 就达不到去除brr的目的了

1. Sub ipjp()
   
2. Dim arr As Variant, brr As Variant, i As Byte, j As Byte
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. brr = Range("c1").CurrentRegion
   
6. 
   
7. For i = 2 To UBound(arr)
   
8. d(arr(i, 1)) = ""
   
9. Next
   
10. 
    
11. For j = 2 To UBound(brr)
    
12. If d.Exists(brr(j, 1)) Then d.Remove brr(j, 1)
    
13. Next
    
14. 
    
15. [E2:E100] = ""
    
16. Range("e2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
17. Set d = Nothing
    
18. End Sub

复制代码

wzsy2_mrf

改原程序的话，应该这样

1. Sub ipjp1()
   
2.     Dim arr As Variant, brr As Variant, i As Long, j As Long
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Range("a1").CurrentRegion
   
5.     brr = Range("c1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         For j = 2 To UBound(brr)
   
8.             If arr(i, 1) = brr(j, 1) Then Exit For
   
9.         Next
   
10.         If j > UBound(brr) Then d(arr(i, 1)) = ""
    
11.     Next
    
12.     Range("e2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
13.     Set d = Nothing
    
14. End Sub
    
15. 
    

复制代码

辣椒油3

1. Sub ljy()
   
2.     Dim arr, brr, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = [c1].CurrentRegion
   
6.     brr = [a1].CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.          If Not d.exists(arr(i, 1)) Then
   
9.         d(arr(i, 1)) = ""
   
10.         End If
    
11.     Next
    
12.     For i = 2 To UBound(brr)
    
13.     If Not d.exists(brr(i, 1)) Then
    
14.             d1(brr(i, 1)) = ""
    
15.         End If
    
16.     Next
    
17.      [e2].Resize(d1.Count) = Application.Transpose(d1.keys)
    
18.    
    
19. End Sub
    

复制代码

fxl447098457

1. Sub ipjp()
   
2. Dim arr, brr, i As Byte, j As Byte, Flag As Boolean
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. brr = Range("c1").CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.    For j = 2 To UBound(brr)
   
8.         If arr(i, 1) = brr(j, 1) Then Flag = True: Exit For
   
9.     Next j
   
10.     If Not Flag Then
    
11.       If Not d.exists(arr(i, 1)) Then d(arr(i, 1)) = ""
    
12.     End If
    
13.     Flag = False
    
14. Next i
    
15. [e2:e256].ClearContents
    
16. [e2].Resize(d.Count) = Application.Transpose(d.keys)
    
17. Set d = Nothing
    
18. End Sub

复制代码

wzsy2_mrf

对这个问题，原程序循环对比且没有写对，当属最差。用双字典没有必要，毕竟多个字典多个系统开销；用remove也不是好方法，因为remove意味着字典剪枝重组，会影响效率。