求助使用VBA找出重复值并标色

ilysw

由于常常整理一些序号，写了二段宏，其中第一段是在A列当中寻找2个相同的序号并同时标上颜色，

第二段是在A列找出2个相同的序号并给于其中一个进行标示文字，

但是现在有一个麻烦，就是当数据达到九十多万笔时，运算较慢，不知何解，特以求助各位，谢谢。

1. 
   
2. Sub 在另一列标示重复()
   
3. 
   
4. Dim a, i
   
5. Sheet1.Select
   
6. Columns("b:b").ClearContents
   
7. r = [a1000000].End(3).Row
   
8. arr = Range("a2:a" & r)
   
9. Set a = CreateObject("Scripting.dictionary")
   
10. For i = 1 To UBound(arr)
    
11.     If a.exists(arr(i, 1)) Then
    
12.        Range("b" & i + 1) = "重复条码"
    
13.        n = a(arr(i, 1))
    
14.        Range("b" & n + 1) = "找出重复条码"
    
15.     Else
    
16.        a.Add arr(i, 1), m
    
17.     End If
    
18. Next
    
19. Set a = Nothing
    
20. End Sub

复制代码

1. 
   
2. Sub 同一列重复标黄色()
   
3. Dim d As Object, i&, n&, rng
   
4. Sheet1.Select
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. rng = Range([a1], [a1000000].End(xlUp))
   
7.   For i = 1 To UBound(rng)
   
8.          If d(rng(i, 1)) = "" Then
   
9.           d(rng(i, 1)) = i
   
10.          Else
    
11.          Union(Cells(i, 1), Cells(d(rng(i, 1)), 1)).Interior.ColorIndex = 6
    
12.       End If
    
13.   Next
    
14. End Sub
    

复制代码

1099287870

把90w的数据装到字典里肯定会有点慢的

ilysw

刚刚有找到别的老师写的，尝试改一下后运算只有15秒，用九十万笔数据算的，但另一个还在尝试 ……唉唉

1. 
   
2. Sub 同一列重复标黄D色()
   
3. Dim Arr, i&, Myr&, d
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. [c:c].Clear
   
7. Myr = [a1000000].End(xlUp).Row
   
8. Arr = Range("a1:A" & Myr)
   
9. For i = 2 To UBound(Arr)
   
10.     If Not d.exists(Arr(i, 1)) Then
    
11.         d(Arr(i, 1)) = ""
    
12.     Else
    
13.         Cells(i, 3) = 1
    
14.     End If
    
15. Next
    
16. End Sub
    

复制代码

liulang0808

楼主上传附件，举例说明下需求吧

ilysw

不好意思，附件已上传，麻烦指教，谢谢。

hlly888

ilysw 发表于 2015-12-18 12:22
不好意思，附件已上传，麻烦指教，谢谢。

1. Sub yy() 'hlly888
   
2. [b2].Resize(Rows.Count - 1, 1).ClearContents
   
3. Application.ScreenUpdating = False
   
4. Dim dc As Object, arr, brr(), i&, w, s&
   
5. Set dc = CreateObject("scripting.dictionary")
   
6. arr = [a1].CurrentRegion
   
7. ReDim brr(1 To UBound(arr), 1 To 1)
   
8. ReDim crr(1 To UBound(arr), 1 To 1)
   
9.    
   
10.     For i = 2 To UBound(arr)
    
11.         w = dc(arr(i, 1))
    
12.         If w = "" Then
    
13.            s = s + 1: dc(arr(i, 1)) = s
    
14.            brr(s, 1) = s + 1
    
15.         Else
    
16.            brr(w, 1) = brr(w, 1) & "-" & i
    
17.            crr(w, 1) = brr(w, 1) & "行"
    
18.         End If
    
19.     Next
    
20.   
    
21. [b2].Resize(UBound(arr), 1) = crr
    
22. Application.ScreenUpdating = True
    
23. End Sub
    

复制代码

hlly888

ilysw 发表于 2015-12-18 12:22
不好意思，附件已上传，麻烦指教，谢谢。

找出2个相同的序号.zip (16.59 KB, 下载次数: 334)

2015-12-18 13:50 上传

点击文件名下载附件

ilysw

谢谢hlly888老师协助，的确快很多，但另外想问可否将a列标上颜色，因为筛选时要把相同重复值列出来。

ilysw

再请问一下hlly888老师，可否填充时可以像这图片一样吗?

yoyolooming

问一下，楼主用哪个工具发的代码，还能点击复制