2工作簿同名表核对数据只有一个表核对了是代码有问题？

liyvan

两个工作簿的同名表进行数据核对，现在只有一个表G21核对是对的，请大神给我修改代码，按照sheet3列给出的表名称核对同名表数据，其他没列出的表不需要核对数据，谢谢

1. Sub lqxs2()
   
2. Dim Arr, myPath$, nm$, I&, Brr, aa, r, r1, l, l1, y&, j&, n&
   
3. On Error Resume Next
   
4. myPath = ThisWorkbook.Path & "\B.xlsx"
   
5. ReDim Brr(1 To Sheets.Count)
   
6. With GetObject(myPath)
   
7. 
   
8. On Error Resume Next
   
9. 
   
10. 
    
11. 
    
12. 
    
13. 
    
14. 'For x = 1 To [b65536].End(3).Row
    
15. For I = 1 To .Sheets.Count
    
16. 
    
17. Z = Cells(I, 2)
    
18. 
    
19. 
    
20. 
    
21. 
    
22. 
    
23. 
    
24. 
    
25. 
    
26. 'For I = 1 To .Sheets.Count
    
27. 
    
28. 
    
29. 
    
30.   .Sheets(I).Name = Z
    
31.   
    
32. 
    
33.         Brr(I) = .Sheets(Z).UsedRange
    
34. Next
    
35. 'Next
    
36.     .Close False
    
37. End With
    
38. 
    
39. For I = 1 To Sheets.Count
    
40. 
    
41. 'For x = 1 To [b65536].End(3).Row
    
42. 
    
43. Z = Cells(I, 2)
    
44. 
    
45. Sheets(I).Name = Z
    
46. 
    
47. 'For I = Sheets(x).Name To Sheets.Count
    
48. 
    
49. 
    
50.     nm = Sheets(Z).Name: n = 0
    
51.     aa = nm & "表格中有以下不同的单元格：" & vbCrLf
    
52.     Arr = Sheets(Z).UsedRange
    
53.     r = UBound(Arr): r1 = UBound(Brr(I))
    
54.     l = UBound(Arr, 2): l1 = UBound(Brr(I), 2)
    
55.     If r >= r1 Then m = r Else m = r1
    
56.     If l >= l1 Then c = l Else c = l1
    
57.     For j = 1 To m
    
58.         For y = 1 To c
    
59.             If Arr(j, y) <> Brr(I)(j, y) Then
    
60.                 n = n + 1
    
61.                 aa = aa & Cells(j, y).Address(0, 0) & vbCrLf
    
62.             End If
    
63.         Next
    
64.     Next
    
65.   
    
66.     If n > 0 Then
    
67.         MsgBox aa
    
68.     Else
    
69.         MsgBox nm & "表格没有不同。"
    
70.     End If
    
71. Next
    
72. 'Next
    
73. End Sub
    
74. 
    

复制代码

蓝桥玄霜

请见代码。

1. Sub lqxs2()
   
2. Dim Arr, myPath$, nm$, I&, Brr, aa, r, r1, l, l1, y&, j&, n&
   
3. Dim d, k, t, wk1 As Workbook, wk2 As Workbook, Crr
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Dim Sht As Worksheet
   
6. Set wk1 = ThisWorkbook
   
7. For Each Sht In Sheets
   
8.     d(Sht.Name) = ""
   
9. Next
   
10. Brr = Sheet3.[b1].CurrentRegion
    
11. myPath = ThisWorkbook.Path & "\B.xlsx"
    
12. With GetObject(myPath)
    
13.     Set wk2 = Workbooks(myPath)
    
14.     For I = 1 To UBound(Brr)
    
15.         s = Brr(I, 1) & "表格中有以下不同的单元格：" & vbCrLf
    
16.         If d.exists(wk2.Sheets(I).Name) Then
    
17.             Arr = wk1.Sheets(Brr(I, 1)).UsedRange
    
18.             Crr = wk2.Sheets(Brr(I, 1)).UsedRange
    
19.             For x = 1 To UBound(Arr)
    
20.                 For y = 1 To UBound(Arr, 2)
    
21.                     If Arr(x, y) <> Crr(x, y) Then s = s & x & "|" & y & vbCrLf
    
22.                 Next
    
23.             Next
    
24.             If InStr(s, "|") <> 0 Then MsgBox s
    
25.         End If
    
26.     Next
    
27.     .Close False
    
28. End With
    
29. End Sub
    

复制代码

liyvan

蓝桥玄霜 发表于 2018-9-20 13:42
请见代码。

先谢谢了，但是老师提示下标越界，怎么解决
Set wk2 = Workbooks(myPath)