求助：如何让自动调整合并单元格高度的VBA脚本遍历所有工作表

原脚本无法遍历所有工作表的核心原因是：FixMerged中的所有Range调用都没有绑定具体工作表，默认只会操作当前活动工作表，即便你写了遍历循环，实际还是在同一个表上重复操作。

以下是两种可行的修改方案：

方案一：给原脚本增加工作表参数，配合遍历过程使用 #

修改后的FixMerged过程 #

Sub FixMerged(targetSheet As Worksheet)
    Dim mw As Single
    Dim cM As Range
    Dim rng As Range
    Dim cw As Double
    Dim rwht As Double
    Dim ar As Variant
    Dim i As Integer
    
    Application.ScreenUpdating = False
    ' 需要处理的合并单元格区域，可根据实际需求修改
    ar = Array("B32", "B33")
    
    ' 修正数组遍历逻辑，避免漏处理第一个元素（VBA数组默认下标从0开始）
    For i = LBound(ar) To UBound(ar)
        On Error Resume Next
        ' 明确绑定到传入的目标工作表，不再依赖活动表
        Set rng = targetSheet.Range(targetSheet.Range(ar(i)).MergeArea.Address)
        On Error GoTo 0 ' 恢复默认错误处理，避免隐藏其他问题
        
        ' 确保找到有效区域再执行后续操作
        If Not rng Is Nothing Then
            With rng
                .MergeCells = False
                cw = .Cells(1).ColumnWidth
                mw = 0
                
                For Each cM In rng
                    cM.WrapText = True
                    mw = cM.ColumnWidth + mw
                Next
                
                mw = mw + rng.Cells.Count * 0.66
                .Cells(1).ColumnWidth = mw
                .EntireRow.AutoFit
                rwht = .RowHeight
                .Cells(1).ColumnWidth = cw
                .MergeCells = True
                .RowHeight = rwht
            End With
        End If
    Next i
    
    Application.ScreenUpdating = True
End Sub

修改后的遍历过程WorksheetLoop #

Sub WorksheetLoop()
    Dim currentSheet As Worksheet
    
    ' 遍历当前工作簿的所有工作表
    For Each currentSheet In ThisWorkbook.Worksheets
        ' 将当前工作表传入FixMerged处理
        FixMerged currentSheet
    Next
End Sub

方案二：整合遍历逻辑到单个过程中 #

如果不需要保留原FixMerged的单独调用能力，可以直接把遍历逻辑和处理逻辑合并，减少过程数量：

Sub FixMergedAllSheets()
    Dim mw As Single
    Dim cM As Range
    Dim rng As Range
    Dim cw As Double
    Dim rwht As Double
    Dim ar As Variant
    Dim i As Integer
    Dim currentSheet As Worksheet
    
    Application.ScreenUpdating = False
    ar = Array("B32", "B33")
    
    ' 遍历所有工作表
    For Each currentSheet In ThisWorkbook.Worksheets
        ' 处理当前工作表中的目标合并单元格
        For i = LBound(ar) To UBound(ar)
            On Error Resume Next
            Set rng = currentSheet.Range(currentSheet.Range(ar(i)).MergeArea.Address)
            On Error GoTo 0
            
            If Not rng Is Nothing Then
                With rng
                    .MergeCells = False
                    cw = .Cells(1).ColumnWidth
                    mw = 0
                    
                    For Each cM In rng
                        cM.WrapText = True
                        mw = cM.ColumnWidth + mw
                    Next
                    
                    mw = mw + rng.Cells.Count * 0.66
                    .Cells(1).ColumnWidth = mw
                    .EntireRow.AutoFit
                    rwht = .RowHeight
                    .Cells(1).ColumnWidth = cw
                    .MergeCells = True
                    .RowHeight = rwht
                End With
            End If
        Next i
    Next currentSheet
    
    Application.ScreenUpdating = True
End Sub

额外注意事项 #

• 原代码中For i = 1 To UBound(ar)存在逻辑漏洞：VBA数组默认下标从0开始，这会导致第一个元素（"B32"）被跳过，改成LBound(ar) To UBound(ar)可以适配所有数组下标情况。
• 添加了错误处理恢复和区域有效性判断，避免因目标单元格不存在、未合并等情况导致的脚本报错或无意义操作。

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