Excel VBA VBA去重复的几种方法

VBA去重复典型有两种方法：
① 整数数值型数据，可以直接使用数组下标去重复
② 通用方法：字典去重复
Sub RecSortTest()
    arr = Array(5, 4, 2, 1, 5, 8, 7, 2, 7, 9, 3, 6, "22", "23", "221", 22, 23, 221, "a", "z", "c") '测试数组
'    arr = WorksheetFunction.Transpose([a1].CurrentRegion) '如果工作表区域要转为一维数组
    trr = RecSort(arr) '仅排序(按默认格式)
    trr1 = RecSort(arr, 1) '去重复排序(按默认格式)
    trr2 = RecSort(arr, 1, 1) '去重复排序 数值不按文本格式
    Stop
End Sub

Function RecSort(arr, Optional z& = 0, Optional c& = 0) 'A-Z 升序排序(/可去重复)的自定义过程
    Dim i&, j&, k&, l&, n&, u&, t
    l = LBound(arr): n = l: u = UBound(arr)
    ReDim trr(l To u)
    
    For i = l To u
        t = arr(i): If c Then If IsNumeric(t) Then t = Val(t) 'c=1 按数值/c=0 按源数据格式
        For j = l To n
            If z Then If trr(j) = t Then n = n - 1: Exit For 'z=1 去重复/z=0 保留
            If trr(j) > t Then '检查直到比当前值t大位置时停止
                For k = n To j + 1 Step -1 '倒序向后移动所有比当前值大的已排序内容 以便腾出空位
                    trr(k) = trr(k - 1)
                Next
                trr(k) = t '空位写入t
                Exit For
            End If
        Next
        If j > n Then trr(j - 1) = t '如果都没有比当前值大 则在最后新的位置写入t
        n = n + 1
    Next
    If z Then ReDim Preserve trr(l To n - 1)
    RecSort = trr
End Function

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

字典去重
Sub 矩形3_Click()
    i = Range("A65536").End(xlUp).Row
    Dim dic As Object, ii&, arr, ra
    Set dic = CreateObject("Scripting.Dictionary")
    arr = Range("a1:a" & i)
    For ii = 1 To UBound(arr)
        ra = dic(arr(ii, 1))
    Next
    Range("a:a").ClearContents
    Range("a1").Resize(dic.Count, 1) = Application.Transpose(dic.Keys)
End Sub

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

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

转自ExcelHome aoe1981 香川群子

http://club.excelhome.net/thread-888978-1-1.html