[已解决]VBA单列重复数据标识改为：多列重复数据标识

yjwdjfqb

老师们好，这个只是单列重复数据标识
请老师们帮帮修改下，改为：多列数据同时重复时，标识出来，并提示重复的行数
如：（可以任意选择多少列）
如图：
请老师们帮帮忙，谢谢大家了！


VBA单列标识重复数据　改为，多列标识重复数据.rar (14.95 KB, 下载次数: 13)

2016-12-12 16:08 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-13 09:00

1. Sub 多列标识重复数据()
   
2.     Dim arr, i&, j&
   
3.     On Error Resume Next
   
4.     Cells.Interior.Pattern = xlNone    '选择范围填充为无色
   
5.     Set Rng = Application.InputBox(prompt:="请选择要标识重复数据的区域", Title:="提示", Default:="请选择", Type:=8)
   
6.     If Rng Is Nothing Then Exit Sub
   
7.     Set Rng = Application.Intersect(Rng, ActiveSheet.UsedRange)
   
8.     arr = Rng
   
9.     xColor = 6    '标识的颜色
   
10.     Set dic = CreateObject("scripting.dictionary")
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     For i = 1 To UBound(arr)    '遍历数组arr
    
13.         s = ""
    
14.         For j = 1 To UBound(arr, 2)
    
15.             s = s & arr(i, j)
    
16.         Next
    
17.         d(s) = d(s) & "," & Rng(i, j).Row
    
18.         For j = 1 To UBound(arr, 2)
    
19.             dic(s) = dic(s) & "," & Rng(i, j).Address(0, 0)
    
20.         Next
    
21.     Next i
    
22.     For Each s In dic.keys
    
23.         If InStr(Mid(d(s), 2), ",") > 0 Then
    
24.              Range(Mid(dic(s), 2)).Interior.ColorIndex = xColor   '标识颜色
    
25.              msg = msg & Chr(10) & "第" & Mid(d(s), 2) & "行重复"
    
26.         End If
    
27.     Next
    
28.     If Len(msg) Then MsgBox Mid(msg, 2) Else MsgBox "无重复行"
    
29. End Sub
    

复制代码

跳转到最佳答案楼层

yjwdjfqb

请老师们帮帮忙，谢谢大家了！

wanao2008

请测试：

1. Sub wanao()
   
2.     Dim arr, Dic, Str As String
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     arr = Range("a1").CurrentRegion
   
5.     For x = 2 To UBound(arr)
   
6.         For y = 2 To 8
   
7.             Str = Str & Cells(x, y)
   
8.         Next
   
9.         If Dic.exists(Str) Then
   
10.             MsgBox "发现重复数据在第 " & Dic(Str) & " 行与第 " & x & " 行。"
    
11.         Else
    
12.             Dic(Str) = x
    
13.         End If
    
14.         Str = ""
    
15.     Next
    
16. End Sub
    

复制代码

yjwdjfqb

wanao2008 发表于 2016-12-12 20:17
请测试：

谢谢老师的帮助，是这样的
我是想通过
Rng = Application.InputBox(prompt:="请选择要标识重复数据的区域", Title:="提示", Default:="请选择", Type:=8)
来选择，多少列到多少列
来确定，重复的数据列

将重复的发行用黄色标识出来，提示，多少行与多少行重复，可否放在一个提示框中

谢谢老师了!

grf1973

1. Sub 多列标识重复数据()
   
2.     Dim arr, i&, j&
   
3.     On Error Resume Next
   
4.     Cells.Interior.Pattern = xlNone    '选择范围填充为无色
   
5.     Set Rng = Application.InputBox(prompt:="请选择要标识重复数据的区域", Title:="提示", Default:="请选择", Type:=8)
   
6.     If Rng Is Nothing Then Exit Sub
   
7.     Set Rng = Application.Intersect(Rng, ActiveSheet.UsedRange)
   
8.     arr = Rng
   
9.     xColor = 6    '标识的颜色
   
10.     Set dic = CreateObject("scripting.dictionary")
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     For i = 1 To UBound(arr)    '遍历数组arr
    
13.         s = ""
    
14.         For j = 1 To UBound(arr, 2)
    
15.             s = s & arr(i, j)
    
16.         Next
    
17.         d(s) = d(s) & "," & Rng(i, j).Row
    
18.         For j = 1 To UBound(arr, 2)
    
19.             dic(s) = dic(s) & "," & Rng(i, j).Address(0, 0)
    
20.         Next
    
21.     Next i
    
22.     For Each s In dic.keys
    
23.         If InStr(Mid(d(s), 2), ",") > 0 Then
    
24.              Range(Mid(dic(s), 2)).Interior.ColorIndex = xColor   '标识颜色
    
25.              msg = msg & Chr(10) & "第" & Mid(d(s), 2) & "行重复"
    
26.         End If
    
27.     Next
    
28.     If Len(msg) Then MsgBox Mid(msg, 2) Else MsgBox "无重复行"
    
29. End Sub
    

复制代码

yjwdjfqb

grf1973 发表于 2016-12-13 09:00

谢谢老师了，非常的好用！

yjwdjfqb

grf1973 发表于 2016-12-13 09:00

老师你好，今天在用的时候，想把重复的行删除，用老师的代码查找出重复行后，
手工删除重复行，太慢了
请老师帮我增加个，将查找到的重复行，删除，保留最后一次出现的数据好吧，谢谢老师了！
VBA多列标识重复数据，（增加删除重复数据行）.rar (12.28 KB, 下载次数: 3)

2016-12-16 11:36 上传

点击文件名下载附件

grf1973

请看附件。