遍历工作簿多工作表时循环中断的VBA代码问题排查

问题场景 #

需要批量清理文件夹中含多工作表的Excel文件，处理任务如下：

• 删除名称以“Block”开头的工作表
• 删除所有隐藏工作表
• 对保留的工作表执行以下操作：
  1. 取消所有单元格合并
  2. 复制UsedRange区域的非合并单元格数据
  3. 将复制的数据转置粘贴到该工作表最后一行下方
  4. 删除转置粘贴前的原始数据行
  5. 删除第4列到标题为“Write offs”的列之前的所有列

故障现象 #

• 当工作簿存在多个“Block”工作表或多个需保留工作表时，代码运行中断
• 移除第5步（删除指定列），或仅存在单个“Block”工作表+单个保留工作表时，代码可正常执行

故障原因分析 #

1. 遍历集合时删除元素导致的异常：直接在For Each ws In masterWB.Worksheets循环中删除工作表，会破坏工作表集合的遍历顺序，引发后续遍历错误
2. 未限定对象的单元格引用：ws.Range(Cells(,5), Cells(,Lastcolumn-1))中的Cells未指定所属工作表，默认引用当前活动工作表，切换工作表时会触发引用错误
3. Match函数未处理匹配失败：若工作表中无“Write offs”标题，WorksheetFunction.Match会直接报错中断代码
4. 原始数据删除范围错误：ws.Range("A1" & ":A" & Lastrow).EntireRow.Delete写法错误，实际应删除转置粘贴起始行之前的所有原始行

修正后的代码 #

Public Sub preparereports()
    Dim MyFSO As FileSystemObject
    Dim folderPath As String
    Dim targetFolder As Folder
    Dim fileItem As File
    Dim masterWB As Workbook
    Dim ws As Worksheet
    Dim wsIndex As Integer
    Dim usedRng As Range
    Dim lastRow As Long
    Dim lastColumn As Variant ' 兼容Match返回错误值的情况

    Set MyFSO = New FileSystemObject
    folderPath = ThisWorkbook.Worksheets(1).Range("A2").Value
    Set targetFolder = MyFSO.GetFolder(folderPath)

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .AskToUpdateLinks = False
    End With

    ' 遍历文件夹内的Excel文件
    For Each fileItem In targetFolder.Files
        If LCase(Right(fileItem.Name, 3)) = "xls" Or LCase(Right(fileItem.Name, 4)) = "xlsx" Then
            Set masterWB = Workbooks.Open(fileItem.Path)
            
            ' 反向遍历工作表，避免删除操作破坏集合顺序
            For wsIndex = masterWB.Worksheets.Count To 1 Step -1
                Set ws = masterWB.Worksheets(wsIndex)
                
                ' 删除目标工作表
                If Left(ws.Name, 5) = "Block" Or ws.Visible = xlSheetHidden Then
                    ws.Delete
                Else
                    ' 取消合并并清除格式
                    ws.Cells.UnMerge
                    ws.Cells.ClearFormats
                    
                    ' 复制UsedRange数据
                    Set usedRng = ws.UsedRange
                    usedRng.Copy
                    
                    ' 获取转置粘贴起始行
                    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
                    ' 转置粘贴值
                    ws.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
                    Application.CutCopyMode = False
                    
                    ' 删除原始数据行
                    ws.Range("A1:A" & (lastRow - 1)).EntireRow.Delete
                    
                    ' 查找目标列，处理匹配失败情况
                    lastColumn = Application.Match("Write offs", ws.Rows(1), 0)
                    If Not IsError(lastColumn) Then
                        ' 明确指定单元格所属工作表，避免跨表引用错误
                        ws.Range(ws.Cells(1, 5), ws.Cells(1, lastColumn - 1)).EntireColumn.Delete
                    End If
                End If
            Next wsIndex
            
            ' 保存并关闭工作簿
            masterWB.Close SaveChanges:=True
        End If
    Next fileItem

    ' 恢复应用程序默认设置
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .AskToUpdateLinks = True
    End With
End Sub

关键修复点说明 #

• 反向遍历工作表：从最后一个工作表往前遍历，删除操作不会影响剩余工作表的遍历逻辑
• 限定单元格对象：所有Cells、Range都明确指定所属工作表ws，杜绝跨工作表引用错误
• 错误处理Match函数：改用Application.Match替代WorksheetFunction.Match，通过IsError判断匹配结果，防止无匹配时崩溃
• 修正删除范围：将原始数据删除范围调整为A1:A" & (lastRow - 1)，确保仅删除转置粘贴前的原始内容
• 变量类型优化：lastColumn设为Variant类型，兼容Match返回错误值的场景
• 规范命名：优化变量名称提升代码可读性

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