[已解决]提取不同，感谢wanao2008老师，麻烦wanao2008老师完善下，谢谢！

love_liwu

已有数据源（假设） 数据筛选.zip (15.25 KB, 下载次数: 4)

2016-12-18 22:12 上传

点击文件名下载附件 ，wanao2008老师提供了以下代码，非常感谢，在实际测试中，发现存在一些问题，麻烦wanao2008老师 帮忙完善下，谢谢！

身份证号码	身份证名称
44090101199101011234	张三
44090101199101011235	张1
44090101199101011236	张2

身份证号码	身份证名称
44090101199101011234	李四
44090101199101011236	张2

效果：

身份证号码	身份证名称
44090101199101011235	张1

通关数据对比，查找不同，需要注意地方，就是从AB列和EF列信息提取不同数据，有些身份证名称与身份证号不同，只要是身份证号码一样，也默认为是相同，则用红色显示。提取位置：放在sheet2表A1。

麻烦各位老师帮忙看看。

最佳答案

月排行榜 / 总排行榜

wanao2008

2016-12-18 19:44

请测试

1. Sub wanao()
   
2.     Dim Dic, a As Integer
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     With Sheet1
   
5.         For x = 2 To .Range("E65536").End(xlUp).Row
   
6.             Dic(.Cells(x, "e").Value) = .Cells(x, "f").Value
   
7.         Next
   
8.         For x = 2 To .Range("E65536").End(xlUp).RowHeight
   
9.             If Not Dic.exists(.Cells(x, "a").Value) Then a = a + 1: .Range("A" & x & ":B" & x).Copy Sheet2.Range("A" & a + 1 & ":B" & a + 1)
   
10.         Next
    
11.     End With
    
12. End Sub
    

复制代码

跳转到最佳答案楼层

wanao2008

请测试

1. Sub wanao()
   
2.     Dim Dic, a As Integer
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     With Sheet1
   
5.         For x = 2 To .Range("E65536").End(xlUp).Row
   
6.             Dic(.Cells(x, "e").Value) = .Cells(x, "f").Value
   
7.         Next
   
8.         For x = 2 To .Range("E65536").End(xlUp).RowHeight
   
9.             If Not Dic.exists(.Cells(x, "a").Value) Then a = a + 1: .Range("A" & x & ":B" & x).Copy Sheet2.Range("A" & a + 1 & ":B" & a + 1)
   
10.         Next
    
11.     End With
    
12. End Sub
    

复制代码

love_liwu

wanao2008 发表于 2016-12-18 19:44
请测试

感谢老师，对于颜色的标识，我用了条件格式。非常感谢老师的关注和帮助。

=VLOOKUP(E1,$A:$B,2,)<>F1 应用于F列
=VLOOKUP(A1,$E:$F,2,)<>B1 应用于B列

love_liwu

wanao2008 发表于 2016-12-18 19:44
请测试

数据筛选.zip (15.25 KB, 下载次数: 3)

2016-12-18 21:18 上传

点击文件名下载附件 代码还不够完善。麻烦老师修改下代码，谢谢！

wanao2008

不好意思，上次的代码有点小错误！

请用下面代码替换

1. Sub wanao()
   
2.     Dim Dic, a As Integer
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     With Sheet1
   
5.         For x = 2 To .Range("E65536").End(xlUp).Row
   
6.             Dic(.Cells(x, "e").Value) = .Cells(x, "f").Value
   
7.         Next
   
8.         .Range("A1:B1").Copy Sheet2.Range("A1:B1")
   
9.         For x = 2 To .Range("A65536").End(xlUp).Row
   
10.             If Not Dic.exists(.Cells(x, "a").Value) Then a = a + 1: .Range("A" & x & ":B" & x).Copy Sheet2.Range("A" & a + 1 & ":B" & a + 1)
    
11.         Next
    
12.     End With
    
13. End Sub
    
14. 
    

复制代码

love_liwu

wanao2008 发表于 2016-12-19 19:15
不好意思，上次的代码有点小错误！

请用下面代码替换

非常感谢@