Excel VBA合并单元格自动调整行高异常：行高过大求助

Hey there! Let's figure out why your VBA code is making rows way taller than needed and get it fixed up properly.

First, let's break down the main issues in your original code:

• Broken column width calculation: You initially loop through all columns in the merged range to sum their widths, but then immediately overwrite that total with just the first two columns' width. That's a huge mistake—this means your code only uses a tiny portion of the actual merged range's width when calculating how tall the row needs to be, leading to overly inflated heights.
• Inaccurate text width measurement: Using Len() to measure text length doesn't account for real-world character widths (e.g., a "W" takes up more space than an "i") or Excel's column width units. We need a way to measure how the text actually displays in the full width of the merged cells.

Here's the revised code that fixes these problems and correctly calculates row heights for merged cells:

Option Explicit

Public Sub AutoFitAll()
    Call AutoFitMergedCells(Sheets("Lead").Range("B4:K4"))
    Call AutoFitMergedCells(Sheets("Lead").Range("B5:K5"))
    Call AutoFitMergedCells(Sheets("Lead").Range("B6:K6"))
End Sub

Public Sub AutoFitMergedCells(oRange As Range)
    Dim totalColWidth As Single
    Dim tempColOriginalWidth As Single
    Dim tempRowHeight As Single
    Dim tempCell As Range
    Dim targetSheet As Worksheet
    
    Set targetSheet = oRange.Parent
    
    With targetSheet
        ' Calculate total width of all columns in the merged range
        totalColWidth = 0
        For Each tempCell In oRange.Columns
            totalColWidth = totalColWidth + tempCell.ColumnWidth
        Next tempCell
        
        ' Grab a temporary cell (using the last column to avoid overwriting your data)
        Set tempCell = .Cells(1, .Columns.Count)
        tempColOriginalWidth = tempCell.ColumnWidth
        
        ' Unmerge the target range temporarily
        oRange.MergeCells = False
        
        ' Copy content, font, and wrap setting to temp cell for accurate measurement
        tempCell.Value = oRange.Cells(1, 1).Value
        tempCell.WrapText = True
        tempCell.Font = oRange.Cells(1, 1).Font
        tempCell.ColumnWidth = totalColWidth
        
        ' AutoFit the temp row to get the exact height needed
        .Rows(tempCell.Row).EntireRow.AutoFit
        tempRowHeight = .Rows(tempCell.Row).RowHeight
        
        ' Apply the calculated height to your target row(s)
        .Rows(oRange.Row & ":" & oRange.Row + oRange.Rows.Count - 1).RowHeight = tempRowHeight
        
        ' Re-merge the original range and restore its wrap setting
        oRange.MergeCells = True
        oRange.WrapText = True
        
        ' Clean up the temp cell so your workbook stays tidy
        tempCell.ClearContents
        tempCell.ColumnWidth = tempColOriginalWidth
        tempCell.WrapText = False
    End With
End Sub

What Changed & Why: #

1. Correct total width calculation: We now properly sum every column in your merged range, so the temp cell matches the exact width of your merged cells when calculating row height.
2. Accurate text measurement: By copying the exact content and font to a temp cell, we ensure the AutoFit uses real display dimensions instead of just character count.
3. Safer temp cell: Using the last column of the sheet avoids conflicts if you already have data in column ZZ.
4. Reusable code: The code now uses the target range's parent sheet instead of hardcoding "Lead", so you can use it on other sheets too.
5. Proper cleanup: We restore the temp cell's original settings so you don't have leftover changes in your workbook.

Quick Test Tip: #

Run the AutoFitAll macro after replacing the code—your merged rows should now fit the content perfectly. If you still see small gaps, check if your target cells have custom indentation or cell margins; you can add lines to copy those settings to the temp cell too if needed.

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