比对两个表格的数据，相同就复制到sheet3

天舞·紫嫣

1、以sheet1为基准，sheet2中的FG两列如果和sheet1中AB两列的数据相符，则把该数据复制到sheet3的AB列中。              
2、号码和姓名都要匹配上~~                                                
3、然后结果数据还需要做一个剔重，在个人的范围内剔重，不涉及其他人

真正sheet1有一万左右数据
sheet2有几千个数据
需要运行速度快~~谢谢各位老师"                                       
                                       
                                       
        

天舞·紫嫣

朱荣兴 发表于 2018-8-17 09:13
一个数组+字典的典型案例，但是：
1、 则把该数据复制到sheet3的AB列中。              是需要复制sheet1 ...

是复制sheet2中的数据，如果sheet2中的号码和姓名和sheet1完全匹配，那么就把这个数据复制到sheet3
全部复制完成后，还需要做一下剔重，比如张三这个人匹配出100个数据，在这100个数据中，有三个相同数据，那么就把这个数据剔重。


这个模拟的数据没问题的，因为原表格涉及号码太多，不方便公布，但是是完全模拟原表格。

老师如果有空请帮我看下怎么弄，表格里有个vba，但是运行起来特别慢

天舞·紫嫣

求助~~~~~~~~~~~~~~~~~~~~

tudarong

朱荣兴 发表于 2018-8-17 09:13
一个数组+字典的典型案例，但是：
1、 则把该数据复制到sheet3的AB列中。              是需要复制sheet1 ...

创建了两个字典，但如何使用exists属性比对，有点懵了，不知道怎么写了，
请大神指点下，谢谢！

1. Sub 比对提取()
   
2.     Dim dic As Object, d As Object
   
3.     Dim i As Long, j As Long, m As Long, n As Long
   
4.     Dim Arr, Brr, Crr
   
5.     Application.ScreenUpdating = False
   
6.     m = Sheet1.Range("A65536").End(xlUp).Row
   
7.     n = Sheet2.Range("F65536").End(xlUp).Row
   
8.     Set dic = CreateObject("scripting.dictionary")
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Arr = Sheet1.Range("A2:B" & m)
    
11.     Brr = Sheet2.Range("F1:G" & n)
    
12.     For i = 1 To UBound(Arr, 1)
    
13.         dic(Arr(i, 1) & Arr(i, 2)) = ""
    
14.     Next
    
15.     For j = 1 To UBound(Brr, 1)
    
16.         d(Brr(j, 1) & Brr(j, 2)) = ""
    
17.     Next
    
18.    
    
19.     '下面比对相同项，并读取出来，有点不知道怎么写了，请大神指点下，谢谢
    
20.     For j = 1 To UBound(Brr, 1)
    
21.         If d.exists(dic.Key) Then
    
22.         
    
23.         End If
    
24.     Next
    
25.     Application.ScreenUpdating = True
    
26. End Sub

复制代码

tudarong

写好了，请测试。
如有帮助，请送朵小花。
请测试.rar (29.4 KB, 下载次数: 223)

2018-8-17 20:32 上传

点击文件名下载附件

1. Sub 比对提取()
   
2.     Dim d As Object
   
3.     Dim i As Long, j As Long, m As Long, n As Long, k As Long
   
4.     Dim Arr, Brr
   
5.     Application.ScreenUpdating = False
   
6.     m = Sheet1.Range("A65536").End(xlUp).Row
   
7.     n = Sheet2.Range("F65536").End(xlUp).Row
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     Arr = Sheet1.Range("A2:B" & m)
   
10.     Brr = Sheet2.Range("F1:G" & n)
    
11.     For j = 1 To UBound(Brr, 1)
    
12.         d(Brr(j, 1) & Brr(j, 2)) = ""
    
13.     Next
    
14.     k = 1
    
15.     For i = 1 To UBound(Arr, 1)
    
16.         If d.exists(Arr(i, 1) & Arr(i, 2)) Then
    
17.             Sheet3.Cells(k, "A") = Arr(i, 1)
    
18.             Sheet3.Cells(k, "B") = Arr(i, 2)
    
19.             k = k + 1
    
20.         End If
    
21.     Next
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

天舞·紫嫣

tudarong 发表于 2018-8-17 20:33
写好了，请测试。
如有帮助，请送朵小花。

太谢谢亲了~~~~这个很好用！！

LMY123

tudarong 发表于 2018-8-17 20:33
写好了，请测试。
如有帮助，请送朵小花。

1. Option Explicit
   
2. 
   
3. Sub 比对提取_学习字典()
   
4.     Dim d As Object
   
5.     Dim i As Long, j As Long, m As Long, n As Long, k As Long
   
6.     Dim Arr, Brr, Crr
   
7.     Application.ScreenUpdating = False
   
8.     m = Sheet1.Range("A65536").End(xlUp).Row
   
9.     n = Sheet2.Range("F65536").End(xlUp).Row
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Arr = Sheet1.Range("A2:B" & m)
    
12.     Brr = Sheet2.Range("F1:G" & n)
    
13.     For j = 1 To UBound(Brr, 1)
    
14.         d(Brr(j, 1) & Brr(j, 2)) = ""
    
15.     Next
    
16. '    k = 1
    
17.     ReDim Crr(1 To UBound(Arr), 1 To UBound(Arr, 2))
    
18.     For i = 1 To UBound(Arr, 1)
    
19.         If d.exists(Arr(i, 1) & Arr(i, 2)) Then
    
20.             k = k + 1
    
21.             Crr(k, 1) = Arr(i, 1)
    
22.             Crr(k, 2) = Arr(i, 2)
    
23. '            k = k + 1
    
24.         End If
    
25.     Next
    
26.     [A1].Resize(k, UBound(Arr, 2)) = Crr
    
27.     Application.ScreenUpdating = True
    
28. End Sub

复制代码