求助代码,取重复值并显示所在行号

lzqmsy

ykqrs 发表于 2016-11-20 16:25

谢谢老师,您的代码正是我需要的,好用,再次谢谢!!!

jsgj2023

ykqrs 发表于 2016-11-20 17:03
没有这个意思，我是说我写的啰嗦，呵呵，VBA也是近一两年才慢慢接触

呵呵，跟您们的代码一对比，我就恨不得找个地洞钻进去啦，惭愧。

fxl447098457

字典套个数组。练习下。。

1. Sub 找重复值()
   
2. Dim d As Object, arr, ar(0 To 6), m, ds
   
3. Set d = VBA.CreateObject("Scripting.dictionary")
   
4. arr = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
   
5. For i& = 2 To UBound(arr)
   
6.     If Not d.Exists(arr(i, 1)) Then
   
7.         ar(0) = 1: ar(ar(0)) = i: d(arr(i, 1)) = ar
   
8.     Else
   
9.         m = d(arr(i, 1)): m(0) = m(0) + 1: m(m(0)) = i: d(arr(i, 1)) = m
   
10.     End If
    
11. Next i
    
12. For Each ds In d.Keys
    
13. If d(ds)(0) = 1 Then d.Remove ds
    
14. Next ds
    
15. [c2:k65536].ClearContents
    
16. [C2].Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
    
17. [D2].Resize(d.Count, 7) = Application.Rept(d.Items, 1)
    
18. End Sub

复制代码

lzqmsy

jsgj2023 发表于 2016-11-20 16:22
老师，请测试。

谢谢您了,我测试了一下,当数据源达到1400行时,用时是33秒,太慢了,我之前做的用时是0,2秒,我嫌慢才来求助的,18楼的快,同样1400行的数据源,我实测用时是0.07秒

jsgj2023

lzqmsy 发表于 2016-11-20 19:56
谢谢您了,我测试了一下,当数据源达到1400行时,用时是33秒,太慢了,我之前做的用时是0,2秒,我嫌慢才来求助 ...

呵呵，我是初学者，还请老师多多指导。

lzqmsy

fxl447098457 发表于 2016-11-20 18:36
字典套个数组。练习下。。

谢谢,但试验不成功

lzqmsy

jsgj2023 发表于 2016-11-20 20:00
呵呵，我是初学者，还请老师多多指导。

Sub 试验()
tt = Timer
Dim d As Object, i%, arr, brr()
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A1").CurrentRegion
For i = 1 To UBound(arr)
    If Not d.Exists(arr(i, 1)) Then
        ReDim brr(1 To 3)
        brr(1) = arr(i, 1)
    Else
        brr = d(arr(i, 1))
    End If
    brr(2) = brr(2) + 1
    brr(3) = brr(3) & i & ","
    d(arr(i, 1)) = brr
Next
For Each aa In d.keys
    If d(aa)(2) = 1 Then
       d.Remove (aa)
    End If
Next
Range("A4").Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.Items))
MsgBox Timer - tt
End Sub
数据源1412行,仅用0.03125秒,是目前最快的代码了

jsgj2023

lzqmsy 发表于 2016-11-20 20:43
Sub 试验()
tt = Timer
Dim d As Object, i%, arr, brr()

学习了，十分精妙。

wzsy2_mrf

1. Sub test()
   
2.     Dim r%, i%, arr, brr, mkey
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     r = Cells(Rows.Count, 1).End(xlUp).Row
   
5.     arr = Range("a1:a" & r)
   
6.     For i = 2 To UBound(arr)
   
7.         If Not d.exists(arr(i, 1)) Then
   
8.             d(arr(i, 1)) = i
   
9.         Else
   
10.             d(arr(i, 1)) = d(arr(i, 1)) & "," & i
    
11.         End If
    
12.     Next
    
13.     ReDim brr(1 To d.Count, 1 To 3)
    
14.     i = 0
    
15.     For Each mkey In d.keys
    
16.         r = UBound(Split(d(mkey), ","))
    
17.         If r > 0 Then
    
18.             i = i + 1: brr(i, 1) = mkey: brr(i, 2) = r + 1: brr(i, 3) = d(mkey)
    
19.         End If
    
20.     Next
    
21.     Range("i2").Resize(10000, UBound(brr, 2)).Clear
    
22.     Range("i2").Resize(i, UBound(brr, 2)) = brr
    
23.     Range("i2").Resize(i, UBound(brr, 2)).Borders.LineStyle = xlContinuous
    
24.     Erase arr, brr: Set d = Nothing
    
25. End Sub
    
26. 
    

复制代码

Vicel

lzqmsy 发表于 2016-11-20 20:43
Sub 试验()
tt = Timer
Dim d As Object, i%, arr, brr()

刚才的代码有误，更正一下
Sub test()
    Dim ar, br(), d As Object, i&, j&, n&
    t = Timer
    Set d = CreateObject("scripting.dictionary")
    ar = Sheets("数据").[A1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If Not d.exists(ar(i, 1)) Then
            d(ar(i, 1)) = i
        Else
            If InStr(d(ar(i, 1)), ",") = 0 Then
                n = n + 1
                d(n) = ar(i, 1)
            End If
            d(ar(i, 1)) = d(ar(i, 1)) & "," & i
        End If
    Next i
    For i = 1 To n
        br(i, 3) = d(d(i))
        br(i, 1) = d(i)
        ar = Split(br(i, 3), ",")
        br(i, 2) = UBound(ar) + 1
    Next i
    [I2].Resize(n, 3) = br
    Set d = Nothing
    MsgBox Timer - t
End Sub