[原创]多行多列取不重复值（VBA版）

andysky

加载宏安装：工具----加载宏----浏览----查找文件---OK

GLWoW2UG.rar (10.5 KB, 下载次数: 4174)

2007-8-22 14:47 上传

点击文件名下载附件
[原创]多行多列取不重复值（VBA版）

[此贴子已经被作者于2008-5-8 10:24:29编辑过]

andysky

繁体版： PGkvJgSH.rar (10.36 KB, 下载次数: 131)

2007-8-22 14:58 上传

点击文件名下载附件
[原创]多行多列取不重复值（VBA版）

gybfdd1218

谢谢，非常需要！真是好贴，顶！

HAPPYYU413

我也要学

http://

zz5151353

收藏 , 謝謝 ANDYSKY 版主提供分享 !!!

[em23][em23][em23][em24][em24][em24][em27][em27][em27]

yxrj

向andysky兄学习，研究了你的去重复值的方法，和狼版的字典的应用，发现andysky的方法还可以提速30多倍，也许还可以更高。

经过测试，在我的电脑上，1万条数据有8000多条不重复的，由6秒多提速到不到0.2秒。

其实也没什么新鲜的，就是将单元格用数组代替了。

文件超过250K了传不上来，发代码吧：

Sub 去重复值()    '支持多区域多行多列
    'On Error Resume Next    '消除选区重复值
    Dim cell As Range, i&, j%, Results As VbMsgBoxResult
    Dim Cn As Integer, Rn&, are As Byte, aa, arr, arr1()
    If Selection.Count = 1 Then MsgBox "请选择要去重复值的区域，再点此按钮。", vbInformation: Exit Sub
    If (Selection.Rows.Count > 1 And Selection.Columns.Count > 1) Or Selection.Areas.Count > 1 Then
        Results = MsgBox("先列后行点击“是（Y）”" & Chr(10) & "先行后列点击“否（N）”", vbYesNo, "取值顺序")
    End If
    aa = Timer
    With CreateObject("Scripting.Dictionary")
        If Results = vbNo Then
            For are = 1 To Selection.Areas.Count
                Set rng = Selection.Areas(are)
                Rn = rng.Rows.Count
                Cn = rng.Columns.Count
                arr = rng
                For i = 1 To Rn
                    For j = 1 To Cn
                        If arr(i, j) <> "" And (Not .Exists(arr(i, j))) Then .Add arr(i, j), ""
                    Next j
                Next i
            Next are
        Else
            For are = 1 To Selection.Areas.Count
                Set rng = Selection.Areas(are)
                Rn = rng.Rows.Count
                Cn = rng.Columns.Count
                arr = rng
                For j = 1 To Cn
                    For i = 1 To Rn
                        If arr(i, j) <> "" And (Not .Exists(arr(i, j))) Then .Add arr(i, j), ""
                    Next i
                Next j
            Next are
        End If
        Selection.ClearContents
        arr = .keys
        ReDim arr1(UBound(arr), 0)
        For i = 0 To UBound(arr)
            arr1(i, 0) = arr(i)
        Next
        'arr = WorksheetFunction.Transpose(.keys) '2000里面不成功
        Selection.Cells(1, 1).Resize(UBound(arr) + 1, 1) = arr1
    End With

    MsgBox "程序共运行了" & Format(Timer - aa, "0.00") & "秒"    '记录程序运行的总时间，timer函数表示当前时间
End Sub

[此贴子已经被作者于2008-1-22 20:49:11编辑过]

ljx63426

good

软件爱好者

收藏 , 謝謝 ANDYSKY 版主提供分享 !!!

xiangjm123

数据能够放到指定的列就好了。

Kelidai

学习的好帖啊