找出两个工作簿身份证号码相同的数据，在Q列标注重复位置

jjmysjg

文件夹内有《工资表》和《信息表》两张工作簿，查找各自表与对方表身份证号码是否重复。如果重复，在表的Q列对应行标注在对方表的重复位置。数据量在80万行左右，希望用VBA完成

谢谢各位老师！

半百

将两个工作表放到一个工作簿里
Sub 查询()
ARR = Sheets("工资表").UsedRange
BRR = Sheets("信息表").UsedRange
For I = 3 To UBound(ARR)
    For J = 3 To UBound(BRR)
        If ARR(I, 5) = BRR(J, 5) Then
            ARR(I, 17) = "信息表" & J & "行"
            BRR(J, 17) = "工资表" & I & "行"
        End If
    Next
Next
Sheets("工资表").UsedRange = ARR
Sheets("信息表").UsedRange = BRR
End Sub

abc123281

仅供参考

1. Sub 查身份证号重复()
   
2. Dim arr, brr
   
3. Dim wb As Workbook
   
4. Dim wb1 As Workbook
   
5. Dim mypath$, myname$
   
6. mypath = ThisWorkbook.Path & ""
   
7. myname = Dir(mypath & "工资表.xlsx")
   
8. Set wb = ThisWorkbook
   
9. With wb
   
10.    With .Worksheets("sheet1")
    
11.      rw = .[e65536].End(xlUp).Row
    
12.      arr = .Range("a3:q" & rw)
    
13.    End With
    
14. End With
    
15. Set wb1 = Workbooks.Open(mypath & myname)
    
16. With wb1
    
17.    With .Worksheets("sheet1")
    
18.      rw = .[e65536].End(xlUp).Row
    
19.      brr = .Range("a3:q" & rw)
    
20.    End With
    
21. End With
    
22. For i = 1 To UBound(arr)
    
23.    For x = 1 To UBound(brr)
    
24.      If arr(i, 5) = brr(x, 5) Then
    
25.        arr(i, 17) = "身份证号与工资表第" & x + 2 & "行重复"
    
26.        brr(x, 17) = "身份证号与信息表第" & i + 2 & "行重复"
    
27.        Exit For
    
28.      End If
    
29.    Next
    
30. Next
    
31. wb.Worksheets("sheet1").[a3].Resize(UBound(arr), 17) = arr
    
32. wb1.Worksheets("sheet1").[a3].Resize(UBound(brr), 17) = brr
    
33. MsgBox "OK"
    
34. End Sub

复制代码

abc123281

参考附件




找出两个工作簿身份证号码相同的数据，在Q列标注重复位置abc123.rar (22.28 KB, 下载次数: 44)

2018-3-20 12:23 上传

点击文件名下载附件

LMY123

找出两个工作簿身份证号码相同的数据，在Q列标注重复位置

jjmysjg

abc123281 发表于 2018-3-20 12:23
参考附件

谢谢abc123281老师！

jjmysjg

半百 发表于 2018-3-20 09:01
将两个工作表放到一个工作簿里
Sub 查询()
ARR = Sheets("工资表").UsedRange

谢谢半百老师！

yangyangde22

Sub 标记重复()
Dim d1 As Object, d2 As Object, wb As Workbook
r1 = Sheets(1).Range("a" & Rows.Count).End(3).Row
arr = Sheets(1).Range("a1:e" & r1)
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For i = 3 To r1
d1(arr(i, 5)) = i
Next
Set wb = Workbooks.Open(ThisWorkbook.Path & "\工资表.xlsx")
r2 = wb.Sheets(1).Range("a" & Rows.Count).End(3).Row
brr = wb.Sheets(1).Range("a1:e" & r2)
For i = 3 To r2
d2(brr(i, 5)) = i
Next
For i = 3 To r2
If d1.exists(brr(i, 5)) Then wb.Sheets(1).Cells(i, 17) = "信息表" & d1(brr(i, 5)) & "行"
Next
wb.Save
wb.Close
For i = 3 To r1
If d2.exists(arr(i, 5)) Then Cells(i, 17) = "工资表" & d2(arr(i, 5)) & "行"
Next
End Sub