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

shaokui123

各显神通啊

LMY123

字典：重复次数及行号

思雪遥遥

各位老师都好厉害！

excel海

这贴为什么这么热闹?

excel海

学习下,不知道这样可好

1. Sub 找重复值()
   
2.     '    MsgBox "谢谢您的帮助!!!" & Chr(10) & "代码可以直接写在模块1里", 64, "提示"
   
3.     Dim i, arr, Keys, Its, brr(), k, t
   
4.     arr = Sheet1.Range("a1").CurrentRegion
   
5.     Dim dic
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.     t = Timer
   
8.     For i = 2 To UBound(arr)
   
9.         If Not dic.exists(arr(i, 1)) Then
   
10.             dic(arr(i, 1)) = i
    
11.         Else
    
12.             dic(arr(i, 1)) = dic(arr(i, 1)) & "," & i
    
13.         End If
    
14.     Next
    
15.     Keys = dic.Keys
    
16.     Its = dic.items
    
17.     For i = 0 To UBound(Keys)
    
18.         If UBound(Split(Its(i), ",")) > 0 Then
    
19.             k = k + 1
    
20.             ReDim Preserve brr(1 To 3, 1 To k)
    
21.             brr(1, k) = Keys(i)
    
22.             brr(2, k) = UBound(Split(Its(i), ",")) + 1
    
23.             brr(3, k) = Its(i)
    
24.         End If
    
25.     Next
    
26.     ReDim crr(1 To UBound(brr, 2), 1 To 3)
    
27.     For i = 1 To UBound(brr, 2)
    
28.         For j = 1 To 3
    
29.             crr(i, j) = brr(j, i)
    
30.         Next
    
31.     Next
    
32.    
    
33.     Sheet1.Range("i5:k5").Resize(UBound(crr)) = crr
    
34.     MsgBox "运行结束,共耗时:" & Timer - t & "s"
    
35. End Sub
    

复制代码

伱幹什仫啊伱

Sub sy1()
Dim arr1(), i&, d1 As Object, d2 As Object, maxrow&
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
maxrow = Sheets("数据").Range("A" & Sheets("数据").Rows.Count).End(xlUp).Row
arr1() = Sheets("数据").Range("A1:A" & maxrow).Value
For i = 2 To maxrow
    d1(arr1(i, 1)) = d1(arr1(i, 1)) + 1
    If d2(arr1(i, 1)) = "" Then
        d2(arr1(i, 1)) = i
    Else
        d2(arr1(i, 1)) = d2(arr1(i, 1)) & "," & i
    End If
Next
Sheets("数据").Range("C1:E1") = Array("重复省份", "出现次数", "所在行号")
Sheets("数据").Range("C2").Resize(UBound(d1.keys()), 1) = Application.Transpose(d1.keys())
Sheets("数据").Range("D2").Resize(UBound(d1.items()), 1) = Application.Transpose(d1.items())
Sheets("数据").Range("E2").Resize(UBound(d2.items()), 1) = Application.Transpose(d2.items())
SendKeys "%{f4}"
End Sub