VBA去重复的几种方法

qiupan_123

好东西，值得好好收藏和学习！

fanweibbt

留下脚印，明天来学习

tec123

學習了，感謝樓主分享

大猫不吃鱼

感谢楼主分享，收藏了

gaolzhen

学习新知识

谢谢分享，欣赏了。。。

杨建营

看到楼主的方法，觉得加上时间判断更容易让人知道运行的速度，因此狗尾续貂，添加了使用时间的过程。

ruirui5015

学习一下！！！！！！！！h

考试加油站

Sub 方法5()
    Dim d, K, t
    With ActiveSheet
        Set d = CreateObject("Scripting.Dictionary")
        K = Range("A65536").End(xlUp).Row
        arr = Range("a1:a" & K)
        For i = 1 To K
            d(arr(i, 1)) = d(arr(i, 1)) + 1
            Cells(i, 2) = d(arr(i, 1))
        Next
        K = d.Keys
        t = d.items
        .Cells(1, 3).Resize(d.Count, 1).clear
        .Cells(1, 4).Resize(d.Count, 1).clear
        .Cells(1, 2).Resize(d.Count, 1).Interior.Color = RGB(255, 255, 0)
        .Cells(1, 3).Resize(d.Count, 1).Interior.ColorIndex = 7
        .Cells(1, 2).Resize(d.Count, 1).NumberFormatLocal = "@"
        .Cells(1, 3).Resize(d.Count, 1).NumberFormatLocal = "@"
        .Cells(1, 3).Resize(d.Count, 1) = Application.Transpose(K)
        .Cells(1, 4).Resize(d.Count, 1) = Application.Transpose(t)
    End With
    Set d = Nothing
End Sub

考试加油站

考试加油站 发表于 2022-10-29 17:40
Sub 方法5()
    Dim d, K, t
    With ActiveSheet

Sub 多列同时去重()

    Dim arr, d As Object, sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    Set rng1 = Application.InputBox("请选择工作表准备参加拆分的完整区域,不要选择整列整行，只选择绝对区域", "选取提示", , , , , , 8)
    If rng1 Is Nothing Then MsgBox "您没有选择要保存的列区域": Exit Sub
    arr = ActiveSheet.Range(rng1.Address)
    Y = UBound(arr, 2)
    HH = UBound(arr, 1)
    With ActiveSheet
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        For j = 1 To UBound(arr, 2)
            n = 0
            Set dic = CreateObject("scripting.dictionary")
            For i = 1 To UBound(arr)
                If Not dic.Exists(arr(i, j)) Then
                    n = n + 1
                    brr(n, j) = arr(i, j)
                    dic(arr(i, j)) = ""
                End If
            Next
        Next
        On Error Resume Next
        Set SHT = Sheets("去重后所得数据")                   '判断"合并"工作表是否存在
        If SHT Is Nothing Then                        '不存在
            Sheets.add.Name = "去重后所得数据"               '添加一个工作表，并命名为"合并"
            Set SHT = Sheets("去重后所得数据")               '把新表赋给变量sht
        Else                                          '存在
            SHT.UsedRange.clear                       '清除"合并"工作表原数据
        End If
        Sheets("去重后所得数据").Range("a1").Resize(UBound(brr), UBound(brr, 2)).NumberFormatLocal = "@"
        Sheets("去重后所得数据").Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
        SHT.Activate
    End With
    Application.ScreenUpdating = 1
End Sub

lrq20501

good...学习一下，可惜没有想要的答案！
只需要去除最后一笔重复的，之前的要留着该怎么写啊@@