[已解决]各位高手 我想求个用vba判断a列是否有相同数据的程序

nanohappy

a列可能有很多条数据，但重复的可能会很少，所以我想用vba的方式，判断a列是否有相同数据，如果存在相同数据，记录其地址并进行提示。 Book.zip (4.26 KB, 下载次数: 10)

2013-7-29 18:36 上传

点击文件名下载附件     感谢各位帮忙！

最佳答案

月排行榜 / 总排行榜

adders

2013-7-30 10:12

nanohappy 发表于 2013-7-29 20:39
感谢！
只要是有相同的数据，用颜色进行标注，  不同重复的数据用其他颜色标示。例如
1

附件中,就点原来的"重复的就诊号着色"按钮

跳转到最佳答案楼层

爱疯

"如果存在相同数据，记录其地址并进行提示。"

怎样记录，怎样提示呢

maicao1986

循环判断怎么样？
依次读取进数组，遇到数组中有的，记录位置并输出

adders

Something like this  - you can modify whatever range you want to check for this line: Set MyRng = Range("A2:A1000")

1. Sub Test()
   
2.     Dim MyRng As Range, Cel As Range, Msg As String
   
3.     Set MyRng = Range("A2:A1000")      ' <--- Modify to your own Range here !!!!!
   
4.     For Each Cel In MyRng
   
5.         If Not IsEmpty(Cel) Then
   
6.             If WorksheetFunction.CountIf(MyRng, Cel) > 1 Then
   
7.                 If Msg = "" Then
   
8.                     Msg = "Duplicated Cells: " & Cel.Address(0, 0)
   
9.                 Else
   
10.                     Msg = Msg & "; " & Cel.Address(0, 0)
    
11.                 End If
    
12.             End If
    
13.         End If
    
14.     Next Cel
    
15.     MsgBox Msg
    
16. End Sub

复制代码

nanohappy

adders 发表于 2013-7-30 02:37
Something like this  - you can modify whatever range you want to check for this line: Set MyRng = Ra ...

感谢这位朋友！
      代码没问题，但是如果重复数据一多，所弹出的提示框根本看不出谁跟谁是重复的了。能否帮我在看看我下面这个附件，谢谢。

nanohappy

爱疯 发表于 2013-7-29 19:10
"如果存在相同数据，记录其地址并进行提示。"

怎样记录，怎样提示呢

谢版主关注，我自己照着网上搞了个，但总有错误，不明白如果改正，请版主帮忙。 底纹着色 问题.zip (18.81 KB, 下载次数: 4)

2013-7-30 09:29 上传

点击文件名下载附件

nanohappy

adders 发表于 2013-7-30 02:37
Something like this  - you can modify whatever range you want to check for this line: Set MyRng = Ra ...

感谢！ 底纹着色 问题.zip (18.81 KB, 下载次数: 0)

2013-7-30 09:35 上传

点击文件名下载附件
只要是有相同的数据，用颜色进行标注，  不同重复的数据用其他颜色标示。例如
1
2
22
1
2
。。。

1 有重复  用红色把两个1的单元格标红
2 有重复  用蓝色把两个2的单元格标红
以此类推

adders

nanohappy 发表于 2013-7-29 20:39
感谢！
只要是有相同的数据，用颜色进行标注，  不同重复的数据用其他颜色标示。例如
1

附件中,就点原来的"重复的就诊号着色"按钮

nanohappy

adders 发表于 2013-7-30 10:12
附件中,就点原来的"重复的就诊号着色"按钮

这位朋友   你的附件没有内容啊。。。

adders

nanohappy 发表于 2013-7-29 21:31
这位朋友   你的附件没有内容啊。。。

可能又是英文版问题,那就用下面的代码吧(在你自己的基础上稍作修改)

1. Private Sub CommandButton1_Click()   '重复就诊号添加底纹
   
2.     Dim cel As Range, rngdata As Range
   
3.     Dim dic As Object
   
4.     Application.ScreenUpdating = False
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     Set rngdata = Range("A2", [a65536].End(3))
   
7.     rngdata.Interior.ColorIndex = xlNone
   
8.     For Each cel In rngdata
   
9.         If Not cel Like "*无*" Then
   
10.             dic(cel.Value) = dic(cel.Value) + 1
    
11.         End If
    
12.     Next cel
    
13.    
    
14.     Dim cIndex As Long  '这里设置底色变量
    
15.     cIndex = 3
    
16.     For Each key In dic.keys
    
17.         If dic(key) > 1 Then
    
18.             For Each cel In rngdata
    
19.                 If cel.Value = key Then
    
20.                     cel.Interior.ColorIndex = cIndex
    
21.                 End If
    
22.             Next cel
    
23.         End If
    
24.         cIndex = cIndex + 1     '每个新Key对应一个新的底色变量
    
25.     Next key
    
26.     Application.ScreenUpdating = True
    
27.     Set dic = Nothing
    
28.     Set rngdata = Nothing
    
29. End Sub

复制代码