字典就这么难学吗？

走近EXCEL

求助，原表中有一点代码，是字典法求不重复数，不知怎也得不到Q列的数据，请老师改一下，谢谢！要求原定义的ARR不变。 字典1.rar (11.39 KB, 下载次数: 19)

2013-4-4 23:17 上传

点击文件名下载附件

clementdong

请参考我修改的代码。
Sub TEST()
    Dim Crr()
    Set d = CreateObject("scripting.dictionary")
    arr = Range("C2:G" & Range("C65536").End(3).Row)
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 3)) Then
            d(arr(i, 3)) = ""
        End If
    Next i
    Range("P2").Resize(d.Count) = Application.Transpose(d.keys)
    d.RemoveAll
    For j = 1 To UBound(arr)
        If Not d.exists(arr(j, 4)) Then
            d(arr(j, 4)) = ""
        End If
    Next j
    Range("Q2").Resize(d.Count) = Application.Transpose(d.keys)
    Set d=Nothing
End Sub

走近EXCEL

clementdong 发表于 2013-4-4 23:34
请参考我修改的代码。

谢谢您！原来是要循环二次，要不然就要加二个字典。

crazy0qwer

走近EXCEL 发表于 2013-4-4 23:38
谢谢您！原来是要循环二次，要不然就要加二个字典。

1. Sub AAA()
   
2.     Dim Arr, Dic As Object
   
3.     Dim N As Long, I As Long
   
4.     Set Dic = CreateObject("scripting.dictionary")
   
5.     Arr = Range("E1:G" & Range("C65536").End(3).Row)
   
6.     N = 1
   
7.     For I = 2 To UBound(Arr)
   
8.         If Not Dic.EXISTS(Arr(I, 1)) Then
   
9.             N = N + 1
   
10.             Arr(N, 1) = Arr(I, 1)
    
11.             Arr(N, 2) = Arr(I, 2)
    
12.             Arr(N, 3) = Arr(I, 3)
    
13.             Dic(Arr(I, 1)) = ""
    
14.         End If
    
15.     Next
    
16.     Range("H1").Resize(N, 3) = Arr
    
17.     Set Dic = Nothing
    
18. End Sub

复制代码

小花鹿

d(arr(i, 3)) = arr(i, 4)

clementdong

小花鹿 发表于 2013-4-4 23:56
d(arr(i, 3)) = arr(i, 4)

谢谢，您的方法真好。

everbest2015

Sub test()
    Dim d As Object, arr, i&, r&, sh As Worksheet
    Set sh = Sheet1
    sh.[p1].Resize(, 2) = Array("编码", "物品名称")
    [p2].Resize(Rows.Count - 1, 2).ClearContents
    Set d = CreateObject("Scripting.Dictionary")
    r = sh.Cells(Rows.Count, 1).End(3).Row
    arr = sh.Range("a1:g" & r)
    For i = 2 To UBound(arr)
            If Not d.exists(arr(i, 5)) Then
                d.Add arr(i, 5), arr(i, 6)
            End If
    Next
    [p2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    Set d = Nothing
End Sub