vba Excel 自动调整行高不适用于带自动换行的 meged 单元格
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19598380/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel autofit row height doesn't work on meged cells with word wrap
提问by Kit
I'm programmatically inserting some text into merged cells in a row. I have Wrap Text set and want the row height to expand as necessary to accommodate multiple lines of text. I was programmatically applying AutoFit once the cells had been filled but that didn't work. I subsequently found a Knowledge Base article saying the AutoFit doesn't work for merged cells! I can try to compute the row height required to accommodate the number of lines of wrapping text. But I don't really want to climb into calculating character widths etc. Any ideas gratefully appreciated.
我以编程方式将一些文本插入到合并的单元格中。我设置了 Wrap Text 并希望根据需要扩展行高以容纳多行文本。一旦单元格被填充，我就以编程方式应用 AutoFit 但这不起作用。我随后发现了一篇知识库文章，说 AutoFit 不适用于合并的单元格！我可以尝试计算容纳环绕文本行数所需的行高。但我真的不想深入计算字符宽度等。任何想法都非常感谢。
Question credit goes to David (I had the exact same question, just reposting here for posterity) source
问题归功于大卫（我有完全相同的问题，只是为了后代重新发布在这里）来源
回答by Kit
I found a VB macro herethat will simulate the autofit of any merged cells on the active sheet. Source credits parry from MrExcel.com
我在这里找到了一个 VB 宏，它将模拟活动工作表上任何合并单元格的自动调整。来自 MrExcel.com 的来源学分招架
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
'Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
End Sub
