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

ljdqe_456

之前发了一贴，估计是说得太复杂了，没有得到帮助  {:soso_e127:}
请看下表或附件，求vba代码实现，查找数据列，有有重复值的在D列标识处该重复值第一次出现时所处的行号，并在E列计出现的次数。
只需关注C列与序号B列当中的1；3；4行相对应的数据
VBA在几年前曾学过，但没学会，现在着急用，
Book1.rar (8.09 KB, 下载次数: 35)

2012-6-18 23:57 上传

点击文件名下载附件

(行号) A	序号 B	数据 C	重复值首次出现所处的行号 D	重复值计数 E
2	1	编号1
3	2	时间: 2012-3-18 17:37
4	3	代号1： 182-242-48-20
5	4	配对号： zsrxlrpsiA613oon
6	5	EEE
7	1	编号2
8	2	时间: 2012-5-19 11:39
9	3	代号1： 121-227-82-218	9	3
10	4	配对号： li-jiegA-yhMM-cc	10	2
11	5	EEE
12	1	编号3
13	2	时间: 2012-5-19 19:53
14	3	代号1： 121-227-82-218	9	3
15	4	配对号： li-jiegA-yhMM-cc	10	2
16	5	EEE
17	1	编号4
18	2	时间: 2012-5-19 10:05
19	3	代号1： 58-19-230-73
20	4	配对号： live6080A-mmMM
21	5	EEE
22	1	编号6
23	2	时间: 2012-5-19 12:18
24	3	代号1： 125-82-238-160
25	4	配对号： 719103875Attoon
26	5	EEE
27	1	编号5
28	2	时间: 2012-5-19 16:09
29	3	代号1： 121-227-82-218	9	3
30	4	配对号： bbzcy0208Axinoon
31	5	EEE

zhaogang1960

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)
   
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
   
9.         ds(arr(i, 1)) = ds(arr(i, 1)) + 1
   
10.     Next
    
11.     For i = 2 To UBound(arr)
    
12.         If ds(arr(i, 1)) > 1 Then
    
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
    

复制代码

zhaogang1960

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

2012-6-19 00:27 上传

点击文件名下载附件

ljdqe_456

zhaogang1960 发表于 2012-6-19 00:27
请看附件

非常感谢，下回来学习学习
vba当成就没学好，由丢了差的十年了  不该丢啊，太遗憾了。
-------------------
发现当中有空行时，已被识别成了相同值了，有办法避免吗？
另外，可用排除列B序号2和5对应的数据，让他们不参加“相同值”的查找吗？

jiminyanyan

ljdqe_456 发表于 2012-6-19 19:08
非常感谢，下回来学习学习
vba当成就没学好，由丢了差的十年了  不该丢啊，太遗憾了。

有基础的话，要用再捡回来．．

ljdqe_456

jiminyanyan 发表于 2012-6-19 19:09
有基础的话，要用再捡回来．．

就是想捡回来，就是丢得太久了

香川群子

ljdqe_456 发表于 2012-6-19 19:08
非常感谢，下回来学习学习
vba当成就没学好，由丢了差的十年了  不该丢啊，太遗憾了。
------------- ...

一个字典解决。

1. Sub kagawa()
   
2.     tms = Timer
   
3.     Dim i%, j%
   
4.     m = [a65536].End(3).Row
   
5.     arr = [b1].Resize(m, 2)
   
6.     ReDim brr(2 To m, 1 To 2)
   
7.    
   
8.     Set d = CreateObject("Scripting.Dictionary")
   
9.     For i = 2 To UBound(arr)
   
10.         If arr(i, 1) <> 2 And arr(i, 1) <> 5 And arr(i, 2) <> "" Then
    
11.             d(arr(i, 2)) = d(arr(i, 2)) & ";" & i
    
12.         End If
    
13.     Next
    
14.     s = d.items
    
15.     For i = 0 To d.Count - 1
    
16.         t = Split(s(i), ";")
    
17.         n = UBound(t)
    
18.         If n > 1 Then
    
19.             For j = 1 To n
    
20.                 brr(t(j), 1) = t(1)
    
21.                 brr(t(j), 2) = n
    
22.             Next
    
23.         End If
    
24.     Next
    
25.     [d2].Resize(m - 1, 2) = brr
    
26.     MsgBox Format(Timer - tms, "0.0000s")
    
27. End Sub

复制代码

香川群子

另写了一个基本以数组为运算过程的代码

1. Sub kagawa2()
   
2. 
   
3.     Dim i%, j%
   
4.    
   
5.     m = [a65536].End(3).Row
   
6.     arr = [b1].Resize(m, 2)
   
7.     ReDim brr(2 To m, 3)
   
8.    
   
9.     Set d = CreateObject("Scripting.Dictionary")
   
10.     For i = 2 To m
    
11.         If arr(i, 1) <> 2 And arr(i, 1) <> 5 And arr(i, 2) <> "" Then
    
12.             t = d(arr(i, 2))
    
13.             If t = "" Then
    
14.                 brr(i, 2) = i
    
15.                 d(arr(i, 2)) = i
    
16.             Else
    
17.                 brr(i, 2) = t
    
18.                 brr(t, 3) = brr(t, 3) + 1
    
19.             End If
    
20.         End If
    
21.     Next
    
22.    
    
23.     For i = 2 To m
    
24.         If brr(i, 2) <> "" Then
    
25.             If brr(brr(i, 2), 3) > 0 Then
    
26.                 brr(i, 0) = brr(i, 2)
    
27.                 brr(i, 1) = brr(brr(i, 2), 3) + 1
    
28.             End If
    
29.         End If
    
30.     Next
    
31.    
    
32.     [d2].Resize(m - 1, 2) = brr
    
33.    
    
34. End Sub

复制代码

请看附件。

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

三种代码速度都差不多。……要看楼主的数据量了。

ljdqe_456

香川群子 发表于 2012-6-19 21:27
一个字典解决。

太棒了！好好学习，争取尽快理解消化了

非常感谢

ljdqe_456

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

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

三种代码速度都很快，我试了一下，二万六千多行，用时都不得1秒钟。
可否再增加注释，便于提高学习的速度。