[讨论]多列中查找重复值的最优方案

qizheng

QUOTE:

以下是引用northwolves在2007-10-25 22:00:58的发言：

仍有提速空间:

Sub macro1()
Dim arr, i As Long, j As Long, n As Long, b(1000000) As Long, t As Single
Application.ScreenUpdating = False
arr = [A1:C60000].Value
t = Timer
For i = 1 To 60000
b(arr(i, 1)) = 1
Next
For j = 2 To 3
For i = 1 To 60000
b(arr(i, j)) = b(arr(i, j)) * j
Next i, j
ReDim arr(1 To 600000, 1 To 1)
For i = 0 To 1000000
If b(i) > 0 Then If b(i) Mod 6 = 0 Then n = n + 1: arr(n, 1) = i
Next
[D1].Resize(n, 1) = arr
Application.ScreenUpdating = True
MsgBox Timer - t & "秒!"
End Sub

返回0.27s

Sub macro2()
Dim arr, i As Long, n As Long, b(1000000) As Byte, t As Single
Application.ScreenUpdating = False
arr = [A1:d60000]
t = Timer
For i = 1 To 60000
b(arr(i, 1)) = 1
Next

For i = 1 To 60000
If b(arr(i, 2)) = 1 Then b(arr(i, 2)) = 2
Next

For i = 1 To 60000
If b(arr(i, 3)) = 2 Then n = n + 1: arr(n, 4) = arr(i, 3)
Next
[D1].Resize(n, 1) = Application.Index(arr, 0, 4)
Application.ScreenUpdating = True
MsgBox Timer - t & "秒!"
End Sub

返回0.18s

运行时出错，错误6，溢出，是怎么回事？急

xq1234

43楼的是够快的，但如果原来的随机数是  Fix(Rnd() * 1000000000) 或者更大的话，那就得 Dim arr, i As Long, n As Long, b(1000000000) As Boolean, c(1000000000) As Boolean, t As Single 甚至更大。

我1G的内存在b(1000000000) As Boolean, c(1000000000) As Boolean就被撑死了！ 

[此贴子已经被作者于2008-6-4 21:16:36编辑过]

xq1234

QUOTE:

以下是引用ldy888在2007-10-31 23:16:53的发言：

再度提速 在狼版基础上再度以空间换时间，加入字典处理不重复值，

Sub Macro22()
    Dim arr, i As Long, n As Long, b(1000000) As Boolean, c(1000000) As Boolean, t As Single
    Application.ScreenUpdating = False
    Dim d As New Dictionary
'    Set d = CreateObject("Scripting.Dictionary")
    arr = Range("a1:c60000")
    t = Timer
    For i = 1 To 60000
        b(arr(i, 1)) = True
    Next

    For i = 1 To 60000
        If b(arr(i, 2)) Then c(arr(i, 2)) = True
    Next
   
    For i = 1 To 60000
        If c(arr(i, 3)) Then d(arr(i, 3)) = 1
    Next
    [d1].Resize(d.Count, 1) = Application.Transpose(d.Keys)
    Application.ScreenUpdating = True
    MsgBox Timer - t & "秒!" ，最快到到 0.0625秒
End Sub

你们检查个以上代码结果的正确性没有?三列数值都重复的情况很少,我觉得上面代码输出的结果不正确也!并且

b(1000000) As Boolean, c(1000000) As Boolean

占用了大量的内存空间.

而且我觉得这个问题没有这么复杂,就像我以下的代码只用了0.09秒，而且只占用了很少的内存:

Sub XQ1234()
    ti = Timer
    Dim myData(), sData(), rData()
    myData = Range("a1:c60000") '赋值给数组
    t = 0
    For r = 1 To 60000
        If myData(r, 1) = myData(r, 2) And myData(r, 2) = myData(r, 3) Then '如果:第一个值等于第二个值 并且 第二个值等于第三个值
            t = t + 1
            ReDim Preserve sData(1 To t)
            ReDim Preserve rData(1 To t)
            sData(t) = myData(r, 1) '重复数值
            rData(t) = r '行号
        End If
    Next r
    If t >= 1 Then
        Cells(10, 6) = "行号"
        Cells(11, 6).Resize(t, 1) = Application.WorksheetFunction.Transpose(rData)
        Cells(10, 7) = "重复数值"
        Cells(11, 7).Resize(t, 1) = Application.WorksheetFunction.Transpose(sData)
        MsgBox "找到" & t & "个重复值,用时 " & Timer - ti & " 秒"
    Else
        MsgBox "没有重复,用时 " & Timer - ti & " 秒"
    End If
End Sub

[此贴子已经被作者于2008-6-4 22:13:23编辑过]

Chzhsh

楼上的好像没有重复值啊

lenghonghai

Private Sub CommandButton1_Click()
Dim x&, i&, m&, rn1 As Range, rn2 As Range, tim
Application.ScreenUpdating = False
tim = Timer
x = Range("a65536").End(xlUp).Row
For i = 1 To x
    Set rn1 = Range("b1:b" & x).Find(Range("a" & i).Value,lookat:=xlwhole): Set rn2 = Range("c1:c" & x).Find(Range("a" & i).Value,lookat:=whole)
    If (Not rn1 Is Nothing) And (Not rn2 Is Nothing) Then
        m = m + 1
        Range("d" & m) = Range("a" & i)
    End If
Next i
MsgBox "计算完毕，共用" & Format(Timer - tim, "0.00") & "秒"
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2007-10-29 14:11:59编辑过]

lenghonghai

上述代码5000个数据用了1分钟左右，如果是60000行数据真不知道程序要运行到什么时候，期待有更快的解决办法。

不知道利用ado+sql能不能更快一些呢？

这方面彭兄不是很擅长吗？

lenghonghai

QUOTE:

以下是引用oobird在2007-10-25 13:13:18的发言：

Private Sub CommandButton1_Click()
  Dim i&, a, b, c, ds As Object, ds1 As Object, ds2 As Object
  Set ds = CreateObject("Scripting.Dictionary")
  Set ds1 = CreateObject("Scripting.Dictionary")
  Set ds2 = CreateObject("Scripting.Dictionary")

  a = [a1:a60000]
  b = [b1:b60000]
  c = [c1:c60000]
  For i = 1 To 60000
    ds(a(i, 1)) = ""
  Next i
  For i = 1 To 60000
    If ds.exists(b(i, 1)) Then ds1(b(i, 1)) = ""
  Next i
  For i = 1 To 60000
    If ds1.exists(c(i, 1)) Then ds2(c(i, 1)) = ""
  Next i
  Cells(1, 4).Resize(ds2.Count, 1) = Application.Transpose(ds2.keys)
  Set ds = Nothing
  Set ds1 = Nothing
  Set ds2 = Nothing

End Sub
先抛块砖吧。

学习了，非常快。就是不太明白其中的原理，版主有空的话可以解释一下吗？

[此贴子已经被作者于2007-10-25 13:25:26编辑过]

lenghonghai

QUOTE:

以下是引用oobird在2007-10-25 13:34:19的发言：

狼版的教学没看吗？很详尽的。对教学内容有不明白的地方请针对不明白的语句提问，这样好回复，呵呵。

我相信必有更快的，搬张沙发等着瞧呢！

看了，有可能没看仔细或者没有完全领会吧。

lenghonghai

QUOTE:

以下是引用张三李四在2007-10-25 14:07:54的发言：

你用的是什么电脑，5000个数据用了1分钟。我的电脑还算是比较好的，500个数据还要1分钟呢。用你的代码测试的。

确实5000个数据只用了58秒，还不到1分钟。

qee用

狼兄的1*2*3很妙,但[D1:D65536] = arr这句很费时间哦.

小改一下,似乎能稍稍快点:

Sub macro2()
Dim arr, i As Long, j As Long, n As Long, b(1000000, 1 To 3) As Boolean
Dim x
Dim t
t = Timer
For j = 1 To 3
arr = Range(Cells(1, j), Cells(60000, j)).Value
For Each x In arr
b(x, j) = True
Next
Next
ReDim arr(1 To 60000, 1 To 1)
For i = 0 To 1000000
If b(i, 1) Then
  If b(i, 2) Then
    If b(i, 3) Then
    n = n + 1: arr(n, 1) = i
    End If
  End If
End If
Next
[d:d].ClearContents
[d1].Resize(n) = arr
Debug.Print Timer - t
End Sub

Ps:

如果不是整数,oobird兄的代码就更通用了.不知道彭兄的底牌是什么?该亮了吧?