VBA去重复的几种方法

wangil

谢谢，学习

aoe1981

以下是楼主的方法1：

1. Sub 矩形1_Click()
   
2.     i = Range("A65536").End(xlUp).Row
   
3.     For s = 1 To i
   
4.         For ss = i To s + 1 Step -1
   
5.             If Cells(ss, 1) = Cells(s, 1) Then
   
6.             Cells(ss, 1).Delete shift:=xlUp
   
7.             End If
   
8.         Next ss
   
9.     Next s
   
10. End Sub

复制代码

感觉与我常用的数组去重是一样的（我是通过两层循环判断比较，重复的清为空值，但是我的做法中，对于后面遇到的空值会跳过，提高运行效率，楼主的，在最后几个单元格会无意义的跑空……），不过，巧妙的是利用了单元格删除后，后面单元格自动上移一格的特点，在内存数组中相当于是把元素前赶了一个位置，如此，不需要另行清除空值了……

aoe1981

楼主方法二：

1. Sub 矩形2_Click()
   
2.     i = Range("A65536").End(xlUp).Row
   
3.     For s = i To 1 Step -1
   
4.         If Application.WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(s, 1)), Cells(s, 1)) > 1 Then
   
5.             Cells(s, 1).Delete shift:=xlUp
   
6.         End If
   
7.     Next
   
8. End Sub

复制代码

函数思维，巧妙利用了单元格删除上移，只需要一个从下往上的单层循环即可，没有跑空……但是每次操作单元格，尤其在循环内部，是效率低的原因吧……

aoe1981

楼主方法三：

1. Sub 矩形3_Click()
   
2.     i = Range("A65536").End(xlUp).Row
   
3.     Dim dic As Object, ii&, arr, ra
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     arr = Range("a1:a" & i)
   
6.     For ii = 1 To UBound(arr)
   
7.         ra = dic(arr(ii, 1))
   
8.     Next
   
9.     Range("a:a").ClearContents
   
10.     Range("a1").Resize(dic.Count, 1) = Application.Transpose(dic.Keys)
    
11. End Sub

复制代码

字典去重，我不习惯这句：ra = dic(arr(ii, 1))，便改成了下面习惯的：

1. Sub 矩形3_Click()
   
2.     i = Range("A65536").End(xlUp).Row
   
3.     Dim dic As Object, ii&, arr
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     arr = Range("a1:a" & i)
   
6.     For ii = 1 To UBound(arr)
   
7.         dic(arr(ii, 1)) = ii
   
8.     Next
   
9.     Range("a:a").ClearContents
   
10.     Range("a1").Resize(dic.Count, 1) = Application.Transpose(dic.Keys)
    
11. End Sub

复制代码

aoe1981

楼主方法四：

1. Sub 矩形4_Click()
   
2. Columns(1).RemoveDuplicates 1
   
3. End Sub

复制代码

咋一看，吓一跳，如此简洁，赶紧F1，才稍稍明白了些真相：
“Excel 开发人员参考
Range.RemoveDuplicates 方法
从值区域中删除重复的值。
版本信息
已添加版本：  Excel 2007

语法

表达式.RemoveDuplicates(Columns, Header)

表达式   一个代表 Range 对象的变量。

参数

名称 必选/可选 数据类型 说明
Columns 可选 Variant 包含重复信息的列的索引数组。如果没有传递任何内容，则假定所有列都包含重复信息。
Header 可选 XlYesNoGuess 指定第一行是否包含标题信息。xlNo 是默认值；如果希望 Excel 确定标题，则指定 xlGuess。
”

香川群子

aoe1981 发表于 2014-12-12 22:20
楼主方法三：字典去重，我不习惯这句：ra = dic(arr(ii, 1))，便改成了下面习惯的：

别整那么多花里胡哨的方法……都不实用。

VBA去重复只有两种方法：
① 整数数值型数据，可以直接使用数组下标去重复

② 通用方法：字典去重复

其它的方法都没啥意思。

aoe1981

香川群子 发表于 2014-12-12 22:38
别整那么多花里胡哨的方法……都不实用。

VBA去重复只有两种方法：

如果考虑普遍性的话，看来只剩下字典去重一种方法了……

我习惯整的是双层循环比对，重复值置空，后次判断跳过空值不再比对的方法……

呵呵……

确实，您的比如：递归组合、经典数组洗牌法等代码都极为经典，在解决很多问题时，都成了我的不二选择……

香川群子

aoe1981 发表于 2014-12-12 22:57
如果考虑普遍性的话，看来只剩下字典去重一种方法了……

我习惯整的是双层循环比对，重复值置空，后次 ...

给你整理个数组循环去重复排序的自定义过程吧，

以后凡是VBA内的一维数组排序，都可以直接拿去用：

1. Sub RecSortTest()
   
2.     arr = Array(5, 4, 2, 1, 5, 8, 7, 2, 7, 9, 3, 6, "22", "23", "221", 22, 23, 221, "a", "z", "c") '测试数组
   
3. '    arr = WorksheetFunction.Transpose([a1].CurrentRegion) '如果工作表区域要转为一维数组
   
4.     trr = RecSort(arr) '仅排序(按默认格式)
   
5.     trr1 = RecSort(arr, 1) '去重复排序(按默认格式)
   
6.     trr2 = RecSort(arr, 1, 1) '去重复排序 数值不按文本格式
   
7.     Stop
   
8. End Sub
   
9. 
   
10. Function RecSort(arr, Optional z& = 0, Optional c& = 0) 'A-Z 升序排序(/可去重复)的自定义过程
    
11.     Dim i&, j&, k&, l&, n&, u&, t
    
12.     l = LBound(arr): n = l: u = UBound(arr)
    
13.     ReDim trr(l To u)
    
14.    
    
15.     For i = l To u
    
16.         t = arr(i): If c Then If IsNumeric(t) Then t = Val(t) 'c=1 按数值/c=0 按源数据格式
    
17.         For j = l To n
    
18.             If z Then If trr(j) = t Then n = n - 1: Exit For 'z=1 去重复/z=0 保留
    
19.             If trr(j) > t Then '检查直到比当前值t大位置时停止
    
20.                 For k = n To j + 1 Step -1 '倒序向后移动所有比当前值大的已排序内容 以便腾出空位
    
21.                     trr(k) = trr(k - 1)
    
22.                 Next
    
23.                 trr(k) = t '空位写入t
    
24.                 Exit For
    
25.             End If
    
26.         Next
    
27.         If j > n Then trr(j - 1) = t '如果都没有比当前值大 则在最后新的位置写入t
    
28.         n = n + 1
    
29.     Next
    
30.     If z Then ReDim Preserve trr(l To n - 1)
    
31.     RecSort = trr
    
32. End Function
    

复制代码

具体算法过程呢，你慢慢研究吧。

这个代码是用了比较插入排序算法，但已由我做了改进。


如果需要降序排序，把比较部分语句中>改成<即可。
If trr(j) > t Then '检查直到比当前值t大位置时停止 结果为A-Z升序排序
If trr(j) < t Then '检查直到比当前值t小位置时停止 结果为Z-A降序排序

neemx

字典加数组

shengmean

感谢分享。。。