这段代码老是提示下标越界9请大神修改一下

liyvan

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
    

复制代码

约定的童话

下标越界的意思是没找到代码里面要求的对象，你在看看你的表格里面有没有不符合要求的区域？比如这两句Brr = Sheet3.[b1].CurrentRegion
myPath = ThisWorkbook.Path & "\B.xlsx"
或者你F8手动运行看下到哪一行报错的，对症下药！

liyvan

约定的童话 发表于 2018-9-22 09:17
下标越界的意思是没找到代码里面要求的对象，你在看看你的表格里面有没有不符合要求的区域？比如这两句Brr  ...

Set wk2 = Workbooks(myPath)这一行报错

lsc900707

liyvan 发表于 2018-9-22 09:32
Set wk2 = Workbooks(myPath)这一行报错

及时给帮助者反馈意见和“评价”，估计你的问题获得满意解答的几率要大得多！

liyvan

lsc900707 发表于 2018-9-22 09:56
及时给帮助者反馈意见和“评价”，估计你的问题获得满意解答的几率要大得多！

好的，谢谢

liyvan

经过3天调试成功，哈哈，备份

1. Sub lqxs4()
   
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. Brr = Sheet3.Range([b1], [B65536].End(3))
    
12. 'myPath = ThisWorkbook.Path & "\b.xlsx"
    
13. myPath = ("C:\Users\Administrator\Desktop\测试\同名表多表格数据的核对\b.xlsx")
    
14. 
    
15. 
    
16. 
    
17. With GetObject(myPath)
    
18. 'With CreateObject("Scripting.FileSystemObject")
    
19. ' Set wk2 = .GetFolder(ThisWorkbook.Path & "\b.xlsx")
    
20.     Set wk2 = Workbooks("b.xlsx")
    
21.     'Set wk2 = ThisWorkbook
    
22.     ' Set wk2 = Workbooks(myPath)
    
23.      
    
24.      
    
25.     ' Set wk2 = Workbooks("B.xlsx").Sheets(3).[B65536].End(xlUp).Row + 1
    
26.      
    
27.     For I = 1 To UBound(Brr)
    
28.         s = Brr(I, 1) & "表格中有以下不同的单元格：" & vbCrLf
    
29.         If d.exists(wk2.Sheets(I).Name) Then
    
30.             Arr = wk1.Sheets(Brr(I, 1)).UsedRange
    
31.             Crr = wk2.Sheets(Brr(I, 1)).UsedRange
    
32.             For X = 1 To UBound(Arr)
    
33.                 For y = 1 To UBound(Arr, 2)
    
34.                
    
35.                    ' If Arr(x, y) <> Crr(x, y) Then s = s & x & "|" & y & vbCrLf
    
36.                     
    
37.                    If Arr(X, y) <> Crr(X, y) Then s = s & Cells(X, y).Address(0, 0) & vbCrLf
    
38.                                  
    
39.                 Next
    
40.             Next
    
41.            'If InStr(s, "|") <> 0 Then MsgBox s
    
42.             If s <> 0 Then MsgBox s
    
43.             Else
    
44.         MsgBox s & "表格没有不同。"
    
45.    
    
46.         End If
    
47.     Next
    
48.     .Close False
    
49. End With
    
50. End Sub

复制代码