比较两个工作薄中同名工作表A列数据的问题

谢玉红

附件 比较两个工作薄中同名工作表A列数据.rar (510.99 KB, 下载次数: 6)

2024-6-10 19:36 上传

点击文件名下载附件

谢谢老师!

EHGOOD

应该还可以再优化优化，这要按1048575行数据量跑，那真够呛。

ykcbf1100

给你加了一列，放工作簿名

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.10
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     sh.[a:d] = ""
   
8.     ReDim zrr(1 To 10000, 1 To 5)
   
9.     f1 = p & "\1.xlsb"
   
10.     f2 = p & "\2.xlsb"
    
11.     Set wb1 = Workbooks.Open(f1, 0)
    
12.     Set wb2 = Workbooks.Open(f2, 0)
    
13.     For Each sht1 In wb1.Sheets
    
14.         d.RemoveAll
    
15.         With sht1
    
16.             r = .Cells(Rows.Count, 1).End(3).Row
    
17.             arr = .[a1].Resize(r, 3)
    
18.             fn1 = .Name
    
19.         End With
    
20.         For i = 1 To UBound(arr)
    
21.             s = arr(i, 1)
    
22.             d(s) = i
    
23.         Next
    
24.         With wb2.Sheets(fn1)
    
25.             r = .Cells(Rows.Count, 1).End(3).Row
    
26.             brr = .[a1].Resize(r, 3)
    
27.             For i = 1 To UBound(brr)
    
28.                 s = brr(i, 1)
    
29.                 If d.exists(s) Then
    
30.                     m = m + 1
    
31.                     zrr(m, 1) = arr(d(s), 1)
    
32.                     zrr(m, 2) = arr(d(s), 2)
    
33.                     zrr(m, 3) = arr(d(s), 3)
    
34.                     zrr(m, 4) = fn1
    
35.                     zrr(m, 5) = wb1.Name
    
36.                     m = m + 1
    
37.                     zrr(m, 1) = brr(i, 1)
    
38.                     zrr(m, 2) = brr(i, 2)
    
39.                     zrr(m, 3) = brr(i, 3)
    
40.                     zrr(m, 4) = .Name
    
41.                     zrr(m, 5) = wb2.Name
    
42.                 End If
    
43.             Next
    
44.         End With
    
45.     Next
    
46.     wb1.Close False
    
47.     wb2.Close False
    
48.     sh.[a1].Resize(m, 5) = zrr
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     Application.DisplayAlerts = True
    
52.     MsgBox "OK！"
    
53. End Sub
    

复制代码