如何解决VBA对比Excel工作表时的Subscript out of range错误？

运行对比两个Excel工作簿工作表的VBA代码时，反复出现“Subscript out of range”错误，调试时错误指向Set ws1 = s1.Sheets(Counter + 1)和Set ws2 = s2.Sheets(Counter + 1)这两行。目前代码输出结果正确，但需要消除错误提示。

原代码 #

Sub Compare_Two_Excel_Sheets()
    'Define Fields
    Dim Flag As Double
  
    Dim iR As Double, iC As Double, oRw As Double
    Dim iRow_M As Double, iCol_M As Double
    Dim s1 As Workbook, s2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim s3 As Workbook
    Dim MyFile As String
    Dim MyFile2 As String
    'List NameShate
    Dim ws As Worksheet
    Dim Counter   As Integer
    
    Counter = 0 ' for the sheetsName
    Flag = 0 '  for the differences
    
    MyFile = ThisWorkbook.Worksheets("vba").Range("C3")
    MyFile2 = ThisWorkbook.Worksheets("vba").Range("C4")

    Set s1 = Workbooks.Open(MyFile)
    Set s2 = Workbooks.Open(MyFile2)
     
    Set ws3 = s2.Sheets.Add(After:=s2.Worksheets(s2.Worksheets.Count))
    ws3.Name = "DETAILS"
    
   
 For Each ws In s2.Worksheets
    ActiveCell.Offset(Counter, 0).Value = ws.Name

    Set ws1 = s1.Sheets(Counter + 1)
   
    Set ws2 = s2.Sheets(Counter + 1)
    
    iRow_M = ws1.UsedRange.Rows.Count
    iCol_M = ws1.UsedRange.Columns.Count
    
    For iR = 1 To iRow_M
    For iC = 1 To iCol_M
        ws1.Cells(iR, iC).Interior.Color = xlNone
        ws2.Cells(iR, iC).Interior.Color = xlNone
        
        If ws1.Cells(iR, iC) <> ws2.Cells(iR, iC) Then
           ws1.Cells(iR, iC).Interior.Color = vbYellow
           ws2.Cells(iR, iC).Interior.Color = vbYellow
           
           oRw = oRw + 1
           ws3.Cells(oRw, 2) = ws2.Cells(iC)
           ws3.Cells(oRw, 3) = ws1.Cells(iR, iC)
           ws3.Cells(oRw, 4) = ws2.Cells(iR, iC)
           Flag = Flag + 1
        End If
        
    Next iC
    Next iR
    
     Counter = Counter + 1
 Next ws 

End Sub

错误原因 #

代码在遍历s2工作表的过程中，新增了名为DETAILS的工作表，导致循环次数超过了s2原本的工作表数量。同时如果s1的工作表数量少于s2（新增后）的数量，当Counter+1超过s1的工作表总数时，就会触发下标越界错误。

解决方案 #

修改代码逻辑，避免遍历新增工作表，同时改用工作表名称匹配（比索引更可靠），添加错误处理避免不存在的工作表引发错误：

Sub Compare_Two_Excel_Sheets()
    '定义变量
    Dim Flag As Double
    Dim iR As Double, iC As Double, oRw As Double
    Dim iRow_M As Double, iCol_M As Double
    Dim s1 As Workbook, s2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim MyFile As String, MyFile2 As String
    Dim Counter As Integer
    Dim sheetCountS2 As Integer '存储s2初始工作表数量
    
    Counter = 0
    Flag = 0
    oRw = 1 '初始化输出行号，避免未定义错误
    
    MyFile = ThisWorkbook.Worksheets("vba").Range("C3")
    MyFile2 = ThisWorkbook.Worksheets("vba").Range("C4")

    Set s1 = Workbooks.Open(MyFile)
    Set s2 = Workbooks.Open(MyFile2)
    
    '先记录s2初始工作表数量，避免遍历到新增的DETAILS表
    sheetCountS2 = s2.Worksheets.Count
     
    Set ws3 = s2.Sheets.Add(After:=s2.Worksheets(s2.Worksheets.Count))
    ws3.Name = "DETAILS"
    '初始化DETAILS表头
    ws3.Cells(1, 1) = "工作表名称"
    ws3.Cells(1, 2) = "列标题"
    ws3.Cells(1, 3) = "工作簿1内容"
    ws3.Cells(1, 4) = "工作簿2内容"
    
    '只遍历s2原本的工作表，不包含新增的DETAILS
    For Counter = 1 To sheetCountS2
        Set ws2 = s2.Worksheets(Counter)
        '按名称查找s1中的对应工作表，避免下标越界
        On Error Resume Next
        Set ws1 = s1.Worksheets(ws2.Name)
        On Error GoTo 0
        
        '如果s1中没有同名表，跳过当前循环
        If ws1 Is Nothing Then
            Debug.Print "工作簿1中不存在工作表：" & ws2.Name
            Set ws1 = Nothing
            Continue For
        End If
        
        '写入工作表名称到ActiveCell
        ActiveCell.Offset(Counter - 1, 0).Value = ws2.Name
        
        iRow_M = ws1.UsedRange.Rows.Count
        iCol_M = ws1.UsedRange.Columns.Count
        
        '批量清除之前的黄色标记，提升效率
        ws1.UsedRange.Interior.Color = xlNone
        ws2.UsedRange.Interior.Color = xlNone
        
        For iR = 1 To iRow_M
            For iC = 1 To iCol_M
                If ws1.Cells(iR, iC) <> ws2.Cells(iR, iC) Then
                    ws1.Cells(iR, iC).Interior.Color = vbYellow
                    ws2.Cells(iR, iC).Interior.Color = vbYellow
                    
                    oRw = oRw + 1
                    ws3.Cells(oRw, 1) = ws2.Name '添加工作表名称，方便定位
                    ws3.Cells(oRw, 2) = ws2.Cells(1, iC) '修正原代码列标题取值错误
                    ws3.Cells(oRw, 3) = ws1.Cells(iR, iC)
                    ws3.Cells(oRw, 4) = ws2.Cells(iR, iC)
                    Flag = Flag + 1
                End If
            Next iC
        Next iR
        
        Set ws1 = Nothing
    Next Counter
    
    '提示对比结果
    MsgBox "对比完成，共发现" & Flag & "处差异", vbInformation
End Sub

修改点说明 #

• 避免遍历新增工作表：先记录s2初始工作表数量，循环时只遍历到该数量，不会处理新增的DETAILS表
• 按名称匹配工作表：不再依赖索引Counter+1，而是用s2工作表名称去s1中查找，避免顺序或数量不匹配导致的错误
• 错误处理：添加On Error Resume Next检查s1是否存在同名表，不存在则跳过
• 修复细节问题：初始化oRw变量，修正DETAILS表列标题的取值错误，添加表头提升可读性

内容的提问来源于stack exchange，提问作者Leo