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

lzqmsy

求助代码,取重复值并显示所在行号,附件中已说明,请老师看附件,谢谢各位老师 VBA找重复值及所在行号的求助.rar (8.69 KB, 下载次数: 57)

2016-11-20 05:29 上传

点击文件名下载附件

jsgj2023

关注一下连大师都不会解的题目。

huang1314wei

1. Sub 找重复值()
   
2.     Dim d, d1, i%, arr
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.         d(arr(i, 1)) = IIf(d(arr(i, 1)) = "", i, d(arr(i, 1)) & "," & i)
   
8.         d1(arr(i, 1)) = d1(arr(i, 1)) + 1
   
9.     Next
   
10.     [I5].Resize(d.Count, 3).Clear
    
11.     [I5].Resize(d.Count, 3) = Application.Transpose(Array(d.keys, d1.Items, d.Items))
    
12. End Sub

复制代码

jsgj2023

1. Sub lfy_Adele()
   
2. Dim d   As Object, arr, r1 As Range, rg  As Range, str As String, crr(1 To 10000, 1 To 6)
   
3. Application.ScreenUpdating = False
   
4. Range("i2:q10000").ClearContents
   
5. arr = Range("a1").CurrentRegion
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. For x = 2 To UBound(arr)
   
8.     d(arr(x, 1)) = d(arr(x, 1)) + 1
   
9. Next x
   
10. s = d.keys: t = d.items
    
11. For x = 0 To UBound(s)
    
12.     With Sheets("数据").Range("A1:A65536")
    
13.         Set c = .Find(s(x), , , 1)
    
14.         If Not c Is Nothing Then
    
15.             firstAddress = c.Address
    
16.             a = c.Row
    
17.             Do
    
18.                 Set c = .FindNext(c)
    
19.                 If Not c Is Nothing Then
    
20.                     If firstAddress <> c.Address Then
    
21.                         aa = c.Row
    
22.                         If Len(aa) Then
    
23.                             n = n + 1: crr(n, 1) = aa
    
24.                         End If
    
25.                     End If
    
26.                 End If
    
27.             Loop While c.Address <> firstAddress
    
28.         End If
    
29.     End With
    
30.     Cells(x + 2, "k") = a: Cells(x + 2, "l").Resize(1, 6) = Application.Transpose(crr)
    
31.      Erase crr: n = 0
    
32.     Next x
    
33. [i2].Resize(d.Count, 1) = Application.Transpose(s)
    
34. [j2].Resize(d.Count, 1) = Application.Transpose(t)
    
35. Application.ScreenUpdating = True
    
36. End Sub

复制代码

Yaong_3

huang1314wei 发表于 2016-11-20 08:10

思路清晰，代码简练，不愧大侠风范。
在此小补一个 IF 判断，屏蔽一下不重复的记录。献丑了。

1. Sub 找重复值()
   
2. Dim d, d1, i%, arr
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = Range("A1").CurrentRegion
   
6.     For i = 2 To UBound(arr)
   
7.     If Application.WorksheetFunction.CountIf(Range("A:A"), arr(i, 1)) > 1 Then
   
8.         d(arr(i, 1)) = IIf(d(arr(i, 1)) = "", i, d(arr(i, 1)) & "," & i)
   
9.         d1(arr(i, 1)) = d1(arr(i, 1)) + 1
   
10.     End If
    
11.     Next
    
12.     [I5].Resize(d.Count, 3).Clear
    
13.     [I5].Resize(d.Count, 3) = Application.Transpose(Array(d.keys, d1.Items, d.Items))
    
14. End Sub

复制代码

jsgj2023

班门弄斧，请老师指导。

lsc900707

大师，献丑了：
Sub lee()
    tms = Time
    Dim arr, i, dr As Object, ds As Object
    arr = Sheet1.Range("a1:a" & [a65536].End(3).Row)
    Set dr = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
         If Application.WorksheetFunction.CountIf([A:A], arr(i, 1)) >= 2 Then
             dr(arr(i, 1)) = dr(arr(i, 1)) + 1
             ds(arr(i, 1)) = ds(arr(i, 1)) & "," & i
         End If
    Next
    Range("I2:K" & [a65536].End(3).Row).ClearContents
    [I2].Resize(dr.Count, 1) = Application.Transpose(dr.keys)
    [J2].Resize(dr.Count, 1) = Application.Transpose(dr.Items)
    [K2].Resize(ds.Count, 1) = Application.Transpose(ds.Items)
    MsgBox Format(Time - tms, "0.0000s")
End Sub

lsc900707

lsc900707 发表于 2016-11-20 09:47
大师，献丑了：
Sub lee()
    tms = Time

附件还是贴一下>>>>>>>>>>>

hhjjpp

我总觉得可以懒一点、少一些、快一次！

1. Private Sub CommandButton1_Click()
   
2. Dim arr, n&, d, drr, i&
   
3. n = [a65536].End(xlUp).Row - 1
   
4. arr = [a2].Resize(n)
   
5. ReDim drr(1 To n, 1 To 10)
   
6. Set d = CreateObject("scripting.dictionary")
   
7. For i = 1 To n
   
8.     If Not d.exists(arr(i, 1)) Then d(arr(i, 1)) = d.Count + 1 '字典item存key序号，利用数组运算，确保使用最少字典
   
9.     drr(d(arr(i, 1)), 1) = drr(d(arr(i, 1)), 1) + 1            'drr(,1)对key出现次数计数
   
10.     drr(d(arr(i, 1)), drr(d(arr(i, 1)), 1) + 1) = i + 1        '写个重复值对应行数到drr
    
11. Next
    
12. [c2].Resize(d.Count) = Application.Transpose(d.keys)
    
13. [d2].Resize(n, 10) = drr
    
14. End Sub
    

复制代码

hhjjpp

1. rivate Sub CommandButton1_Click()
   
2. Dim arr, n&, d, drr, i&
   
3. n = [a65536].End(xlUp).Row - 1
   
4. arr = [a2].Resize(n)
   
5. ReDim drr(1 To n, 1 To 2)
   
6. Set d = CreateObject("scripting.dictionary")
   
7. For i = 1 To n
   
8.     If Not d.exists(arr(i, 1)) Then d(arr(i, 1)) = d.Count + 1                                   '字典item存key序号，利用数组运算，确保使用最少字典
   
9.     drr(d(arr(i, 1)), 1) = drr(d(arr(i, 1)), 1) + 1                                              'drr(,1)对key出现次数计数
   
10.     drr(d(arr(i, 1)), 2) = IIf(drr(d(arr(i, 1)), 1) > 1, drr(d(arr(i, 1)), 2) & ",", "") & i + 1 '重复值行次汇集到drr
    
11. Next
    
12. [p2].Resize(d.Count) = Application.Transpose(d.keys)
    
13. [q2].Resize(n, 2) = drr
    
14. End Sub

复制代码