查找相同值、计数并标记行号

zhaogang1960

ljdqe_456 发表于 2012-6-20 12:32
三种代码速度都很快，我试了一下，二万六千多行，用时都不得1秒钟。
可否再增加注释，便于提高学习的速度 ...

1. Sub Macro1()
   
2.     Dim arr, brr(), i&, d As Object, ds As Object '声明变量
   
3.     Set d = CreateObject("scripting.dictionary") '创建字典对象，下同
   
4.     Set ds = CreateObject("scripting.dictionary")
   
5.     arr = Range("C1:C" & Range("C65536").End(xlUp).Row) 'C列数据写入数组
   
6.     ReDim brr(2 To UBound(arr), 1 To 2) '重新定义动态数组
   
7.     For i = 2 To UBound(arr) '逐行数据
   
8.         If Not d.Exists(arr(i, 1)) Then d(arr(i, 1)) = i '字典d记录该数据首先出现的位置
   
9.         ds(arr(i, 1)) = ds(arr(i, 1)) + 1 '字典ds记录该数据出现的次数
   
10.     Next
    
11.     For i = 2 To UBound(arr) '逐行
    
12.         If ds(arr(i, 1)) > 1 Then '如果该数据出现次数大于1次
    
13.             brr(i, 1) = d(arr(i, 1)) '该重复值首先出的的行号
    
14.             brr(i, 2) = ds(arr(i, 1)) '该重复值出现次数
    
15.         End If
    
16.     Next
    
17.     Range("d2").Resize(i - 2, 2) = brr '写数据
    
18. End Sub
    

复制代码

ljdqe_456

香川群子 发表于 2012-6-19 22:30
另写了一个基本以数组为运算过程的代码请看附件。

赵刚版主代码也顺便按楼主要求做了修改。

感谢版主在11楼增加的注释，正在学习中...
恳请将 8楼的附件也增加上注释，方便学习。
另外我想自行控制 写数据时所写到的列。比如序号1对应的写在D和E列，序号2对应的写在F和G列，序号3对应的写入H和I列，序号4对应的写入J和K列。通过11楼的注释和excel的帮助，没有学到 o(︶︿︶)o

香川群子

ljdqe_456 发表于 2012-6-20 22:52
感谢版主在11楼增加的注释，正在学习中...
恳请将 8楼的附件也增加上注释，方便学习。
另外我想自行控制 ...

楼主你的要求没看懂。

能否上个附件模拟一下呢？

ljdqe_456

Book1.rar (20.33 KB, 下载次数: 14)

2012-6-26 01:07 上传

点击文件名下载附件

香川群子 发表于 2012-6-25 08:59
楼主你的要求没看懂。

能否上个附件模拟一下呢？

首先谢谢你们的热心帮助。
最初你在8楼上的附件，三种方式均能够非常理想的达到我最初想要的效果。但是后来发觉在原始的数据表格上进行处理，会带来其他的问题和不便，因此希望将原始表格转换一下进行处理。
自己试做做了一下，见附件的工作表【原始数据】和【数据整理后】。【数据整理后】工作表中三个按钮是借用11楼赵版主注释过的代码改的，我也知道是太笨了，居然用了三个按钮。

香川群子

附件看了，一下子没有看懂。

我想，你需要再次整理上传附件。
1. 完全按照实际需要的附件
2. 手工模拟出一部分结果
3. 对操作规则的补充说明

ljdqe_456

香川群子 发表于 2012-6-27 13:46
附件看了，一下子没有看懂。

我想，你需要再次整理上传附件。

1、查找编号(B)列的重复值，并在K列显示重复值首次出现所处的行号 ，在（L列）显示该对应值重复的次数；
2、类似的，查找代号（D列）的重复值，在（M列）显示重复值首次出现所处的行号 ，在（N列）显示该对应值重复的次数。 查找配对号（E列）的重复值，在（O列）显示重复值首次出现所处的行号 ，在（P列）显示该对应值重复的次数。

这个表是借用了赵版主的代码，用了3个按钮来完成，可否使用1个按钮解决。（恳请进行注释）
请看附件： Book1.rar (31.2 KB, 下载次数: 15)

2012-6-27 15:55 上传

点击文件名下载附件

另外，这个表标题是从首行起始的，如果标题从10行开始呢。

zhaogang1960

ljdqe_456 发表于 2012-6-27 15:55
1、查找编号(B)列的重复值，并在K列显示重复值首次出现所处的行号 ，在（L列）显示该对应值重复的次数；
...

1. Sub Macro1()
   
2.     Dim a, arr, brr(), i&, j&, n&, d As Object, ds As Object '声明变量
   
3.     Set d = CreateObject("scripting.dictionary") '创建字典对象，下同
   
4.     Set ds = CreateObject("scripting.dictionary")
   
5.     arr = Range("b1:e" & Range("b65536").End(xlUp).Row) 'C列数据写入数组
   
6.     ReDim brr(2 To UBound(arr), 1 To 6) '重新定义动态数组
   
7.     a = Array("", "A", "", "C", "D")
   
8.     For i = 2 To UBound(arr) '逐行数据
   
9.         For j = 1 To 4
   
10.             If j <> 2 Then
    
11.                 If Not d.Exists(a(j) & arr(i, j)) Then d(a(j) & arr(i, j)) = i '字典d记录该数据首先出现的位置
    
12.                 ds(a(j) & arr(i, j)) = ds(a(j) & arr(i, j)) + 1 '字典ds记录该数据出现的次数
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     For i = 2 To UBound(arr) '逐行
    
17.         n = 0
    
18.         For j = 1 To 4
    
19.             If j <> 2 Then
    
20.                 n = n + 2
    
21.                 If ds(a(j) & arr(i, j)) > 1 Then '如果该数据出现次数大于1次
    
22.                     brr(i, n - 1) = d(a(j) & arr(i, j)) '该重复值首先出的的行号
    
23.                     brr(i, n) = ds(a(j) & arr(i, j)) '该重复值出现次数
    
24.                 End If
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     Range("k2").Resize(i - 2, 6) = brr '写数据
    
29. End Sub
    

复制代码

zhaogang1960

请看附件
Book1.rar (33.04 KB, 下载次数: 91)

2012-6-27 23:08 上传

点击文件名下载附件

香川群子

我的两个方法都比赵版的双字典方法快一些。

1. Sub kagawa_dic()
   
2.     tms = Timer
   
3.     Dim i%, j%, m&
   
4.    
   
5.     m = [a65536].End(3).Row
   
6.     arr = [b1].Resize(m, 4)
   
7.     ReDim brr(2 To m, 1 To 6)
   
8.    
   
9.     Set d1 = CreateObject("Scripting.Dictionary")
   
10.     Set d2 = CreateObject("Scripting.Dictionary")
    
11.     Set d3 = CreateObject("Scripting.Dictionary")
    
12.    
    
13.     For i = 2 To m
    
14.         d1(arr(i, 1)) = d1(arr(i, 1)) & ";" & i
    
15.         d2(arr(i, 3)) = d2(arr(i, 3)) & ";" & i
    
16.         d3(arr(i, 4)) = d3(arr(i, 4)) & ";" & i
    
17.     Next
    
18.    
    
19.     s = d1.items
    
20.     Set d1 = Nothing
    
21.     For i = 0 To UBound(s)
    
22.         t = Split(s(i), ";")
    
23.         n = UBound(t)
    
24.         If n > 1 Then
    
25.             For j = 1 To n
    
26.                 brr(t(j), 1) = t(1)
    
27.                 brr(t(j), 2) = n
    
28.             Next
    
29.         End If
    
30.     Next
    
31.    
    
32.     s = d2.items
    
33.     Set d2 = Nothing
    
34.     For i = 0 To UBound(s)
    
35.         t = Split(s(i), ";")
    
36.         n = UBound(t)
    
37.         If n > 1 Then
    
38.             For j = 1 To n
    
39.                 brr(t(j), 3) = t(1)
    
40.                 brr(t(j), 4) = n
    
41.             Next
    
42.         End If
    
43.     Next
    
44.    
    
45.     s = d3.items
    
46.     Set d3 = Nothing
    
47.     For i = 0 To UBound(s)
    
48.         t = Split(s(i), ";")
    
49.         n = UBound(t)
    
50.         If n > 1 Then
    
51.             For j = 1 To n
    
52.                 brr(t(j), 5) = t(1)
    
53.                 brr(t(j), 6) = n
    
54.             Next
    
55.         End If
    
56.     Next
    
57.    
    
58.     [k2].Resize(m - 1, 6) = brr
    
59. '    MsgBox Format(Timer - tms, "0.0000s")
    
60. End Sub

复制代码

这个字典方法速度最快。

1. Sub kagawa_Arr()
   
2.     tms = Timer
   
3.     Dim i%, j%, m&
   
4.    
   
5.     m = [a65536].End(3).Row
   
6.     arr = [b1].Resize(m)
   
7.     ReDim brr(2 To m, 3)
   
8.    
   
9.     Set d = CreateObject("Scripting.Dictionary")
   
10.     For i = 2 To m
    
11.         t = d(arr(i, 1))
    
12.         If t = "" Then
    
13.             brr(i, 2) = i
    
14.             d(arr(i, 1)) = i
    
15.         Else
    
16.             brr(i, 2) = t
    
17.             brr(t, 3) = brr(t, 3) + 1
    
18.         End If
    
19.     Next
    
20.     d.RemoveAll
    
21.    
    
22.     For i = 2 To m
    
23.         If brr(i, 2) <> "" Then
    
24.             If brr(brr(i, 2), 3) > 0 Then
    
25.                 brr(i, 0) = brr(i, 2)
    
26.                 brr(i, 1) = brr(brr(i, 2), 3) + 1
    
27.             End If
    
28.         End If
    
29.     Next
    
30.     [k2].Resize(m - 1, 2) = brr
    
31.    
    
32.     arr = [d1].Resize(m)
    
33.     ReDim brr(2 To m, 3)
    
34.    
    
35.     For i = 2 To m
    
36.         t = d(arr(i, 1))
    
37.         If t = "" Then
    
38.             brr(i, 2) = i
    
39.             d(arr(i, 1)) = i
    
40.         Else
    
41.             brr(i, 2) = t
    
42.             brr(t, 3) = brr(t, 3) + 1
    
43.         End If
    
44.     Next
    
45.     d.RemoveAll
    
46.    
    
47.     For i = 2 To m
    
48.         If brr(i, 2) <> "" Then
    
49.             If brr(brr(i, 2), 3) > 0 Then
    
50.                 brr(i, 0) = brr(i, 2)
    
51.                 brr(i, 1) = brr(brr(i, 2), 3) + 1
    
52.             End If
    
53.         End If
    
54.     Next
    
55.     [m2].Resize(m - 1, 2) = brr
    
56.    
    
57.     arr = [e1].Resize(m)
    
58.     ReDim brr(2 To m, 3)
    
59.    
    
60.     For i = 2 To m
    
61.         t = d(arr(i, 1))
    
62.         If t = "" Then
    
63.             brr(i, 2) = i
    
64.             d(arr(i, 1)) = i
    
65.         Else
    
66.             brr(i, 2) = t
    
67.             brr(t, 3) = brr(t, 3) + 1
    
68.         End If
    
69.     Next
    
70.     Set d = Nothing
    
71.    
    
72.     For i = 2 To m
    
73.         If brr(i, 2) <> "" Then
    
74.             If brr(brr(i, 2), 3) > 0 Then
    
75.                 brr(i, 0) = brr(i, 2)
    
76.                 brr(i, 1) = brr(brr(i, 2), 3) + 1
    
77.             End If
    
78.         End If
    
79.     Next
    
80.     [o2].Resize(m - 1, 2) = brr
    
81.    
    
82. '    MsgBox Format(Timer - tms, "0.0000s")
    
83. End Sub

复制代码

这个字典+数组方法要慢一些。

ljdqe_456

zhaogang1960 发表于 2012-6-27 23:07

谢谢，马上下来学习   o(∩_∩)o