[已解决]单列重复数据查询并显示求助

SMT-AOC

各位好, 用VBA如何实现 可以快速对单列数据查询 是否有重复数据,并输出到另外一列中.  

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-7-27 12:25

高版本打不开,你先试试以下代码,已根据你的说明作了修改

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, j&, d As Object, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("b2:b" & [b65536].End(3).Row)
   
5. j = 1
   
6. For i = 2 To UBound(arr)
   
7.   d(arr(i, 1)) = d(arr(i, 1)) + 1
   
8. Next i
   
9. For Each c In d.KEYS
   
10.   If d(c) = 1 Then d.Remove (c)
    
11. Next c
    
12. MsgBox Join(d.KEYS, ",")
    
13. End Sub

复制代码

跳转到最佳答案楼层

ligh1298

这个可以办到，可没有附件，就不好办到。

zhp3

这样不知是不是你想要的结果？
重复数据查询.zip (2.29 KB, 下载次数: 11)

2013-7-26 14:55 上传

点击文件名下载附件

SMT-AOC

zhp3 发表于 2013-7-26 14:55
这样不知是不是你想要的结果？

用VBA 快速可以实现? 显示只要用msgbox就可以. 只要是提示用.谢谢

大灰狼1976

字典基本用法，附件请测试

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, j&, d As Object, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. j = 2
   
6. For i = 2 To UBound(arr)
   
7.   d(arr(i, 1)) = d(arr(i, 1)) + 1
   
8. Next i
   
9. For Each c In d.keys
   
10.   If d(c) > 1 Then arr(j, 2) = c: j = j + 1
    
11. Next c
    
12. [b1].Resize(UBound(arr)) = Application.Index(arr, 0, 2)
    
13. End Sub

复制代码

SMT-AOC

大灰狼1976 发表于 2013-7-26 15:43
字典基本用法，附件请测试

为什么我复制你的代码,在新的表 里运行就不行,提示下标越界

SMT-AOC

大灰狼1976 发表于 2013-7-26 15:43
字典基本用法，附件请测试

另 我要查找的重复数据在B列里,代码怎么改.

大灰狼1976

arr = [a1].CurrentRegion
这个用法会因为实际的数据区域而改变，所以请上传实际的表格

SMT-AOC

大灰狼1976 发表于 2013-7-26 17:03
arr = [a1].CurrentRegion
这个用法会因为实际的数据区域而改变，所以请上传实际的表格

增加附加.  

adders

SMT-AOC 发表于 2013-7-26 20:57
增加附加.

凑个热闹

1. Sub test()
   
2.     Dim myRng As Range, msg As String
   
3.     Set myRng = Range("B2", Range("B2").End(xlDown))
   
4.    
   
5.     For Each cel In myRng
   
6.         If WorksheetFunction.CountIf(myRng, cel) > 1 Then
   
7.             If msg = "" Then
   
8.                 msg = "有重复数字的单元格: " & cel.Address(0, 0)
   
9.             Else
   
10.                 msg = msg & "; " & cel.Address(0, 0)
    
11.             End If
    
12.         End If
    
13.     Next
    
14.     MsgBox msg
    
15. End Sub

复制代码