关于提取唯一值的完善建议

roc.jame

提取唯一值功能在超过10万以上数据时运行会导致Excel无法响应，本人此前也有过这方面的求助，建议采用灰袍法师写的代码思路。
详见本人的帖子：
请教各位超过60万数据提取不重复值问题？【已解决】
http://club.excelhome.net/thread-892294-1-1.html

1. Sub remove_duplicate_by_sortting()
   
2. Dim i As Long, j As Long, k As Long, count As Long, unique As Long
   
3. Dim key, t, data_in(), arr_sort()
   
4. t = Timer
   
5. Sheets(2).Range("A1").Resize(Rows.count, Columns.count).ClearContents
   
6. Sheets(1).Select
   
7. Randomize
   
8. r = 65536
   
9. c = 13 '一共十三列数据
   
10. data_in = Range("A1").Resize(r, c).Value '读取65536x13的单元格区域
    
11. ReDim arr_sort(1 To r * c)
    
12. count = 0
    
13. For i = 1 To c
    
14.     For j = 1 To r
    
15.         key = CStr(data_in(j, i))
    
16.         If key <> "" Then
    
17.             count = count + 1
    
18.             arr_sort(count) = key
    
19.         End If
    
20.     Next j
    
21. Next i
    
22. Erase data_in
    
23. Call QuickSort(arr_sort, 1, count)
    
24. ReDim arr_out(1 To 65536, 1 To 1)
    
25. key = ""
    
26. j = 0
    
27. k = 1
    
28. For i = 1 To count
    
29.     If arr_sort(i) <> key Then
    
30.         unique = unique + 1
    
31.         key = arr_sort(i)
    
32.         j = j + 1
    
33.         arr_out(j, 1) = key
    
34.         If j = 65536 Then
    
35.             Sheets(2).Cells(1, k).Resize(65536, 1).Value = arr_out
    
36.             ReDim arr_out(1 To 65536, 1 To 1)
    
37.             j = 0
    
38.             k = k + 1
    
39.         End If
    
40.     End If
    
41. Next i
    
42. Sheets(2).Cells(1, k).Resize(j, 1).Value = arr_out
    
43.    
    
44. MsgBox Format(Timer - t, "0.000") & " 秒  " & unique & "  个不重复值"
    
45. End Sub
    
46. Sub QuickSort(Arr_In(), L As Long, r As Long)
    
47. Dim i As Long, j As Long, k As Long, a As Long, b As Long, c As Long
    
48. Dim Pivot, Swap, Insert
    
49.     i = L
    
50.     j = r
    
51.     If r - L <= 12 Then
    
52.         For b = L To r
    
53.             Insert = Arr_In(b)
    
54.             For c = b - 1 To L Step -1
    
55.                 If Insert < Arr_In(c) Then
    
56.                     Arr_In(c + 1) = Arr_In(c)
    
57.                     Arr_In(c) = Insert
    
58.                 Else
    
59.                     Exit For
    
60.                 End If
    
61.             Next c
    
62.         Next b
    
63.     Else
    
64.         Pivot = Arr_In(Int(Rnd * (r - L)) + L)
    
65.         While (i < j)
    
66.             For a = i To r
    
67.                 If Arr_In(a) >= Pivot Then Exit For
    
68.             Next a
    
69.             i = a
    
70.             For b = j To L Step -1
    
71.                 If Arr_In(b) <= Pivot Then Exit For
    
72.             Next b
    
73.             j = b
    
74.             If (a < b) Then
    
75.                 Swap = Arr_In(a)
    
76.                 Arr_In(a) = Arr_In(b)
    
77.                 Arr_In(b) = Swap
    
78.                 i = i + 1
    
79.                 j = j - 1
    
80.             End If
    
81.         Wend
    
82.         If (L < j) Then Call QuickSort(Arr_In, L, j)
    
83.         If (i < r) Then Call QuickSort(Arr_In, i, r)
    
84.     End If
    
85. End Sub

复制代码

该贴已经同步到 roc.jame的微博

ljdqe_456

嗯，谢谢
标记一下，留下记号