Excel VBA自動擬合合並單元格

Question

尊敬的Stackoverflow用戶，

對於項目，我想調整合並行的高度以適合內容。

我在“ extendoffice.com”上找到了以下代碼。 （ https://www.extendoffice.com/documents/excel/2342-excel-autofit-row-height-merged-cells.html?page_comment=3 ）

該代碼看起來很干凈而且很好，但是我無法使其正常工作，我認為這是由於列的大小不同所致。 高度總是很大。

我已經嘗試獲取一個常數，將結果除以2或其他因子，但這不起作用。

您能否看一下並給我指導，如何解決我遇到的高度遠遠超出必要高度的問題。

示例文件： 示例文件

編碼：

    Option Explicit

Public Sub AutoFitAll()

  Call AutoFitMergedCells(Range("B4:K4"))
  Call AutoFitMergedCells(Range("B5:K5"))
  Call AutoFitMergedCells(Range("B6:K6"))

End Sub

Public Sub AutoFitMergedCells(oRange As Range)
  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldWidth As Single
  Dim oldZZWidth As Single
  Dim newWidth As Single
  Dim newHeight As Single
  With Sheets("Lead")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
      oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
  End With
End Sub

提前致謝！

問候，Dubblej

Answer 1

所以我給它一個嘗試按照艾倫悅的建議在這里 。

他建議使用一個輔助列，在我的情況下，該列為P列（不應緊鄰），並具有一個格式相同（合並除外）的單元格指向合並范圍的左上方單元格。

因此，如果您在合並范圍B4:K4具有以下內容：

最初是這樣壓縮的：

在P4放公式=B4

然后放在標准模塊中

Option Explicit

Sub Autofit()

    ActiveSheet.Range("P4").Rows.Autofit

End Sub

似乎可以工作。

Answer 2

這個問題似乎很容易，但是您可以看到有幾個例外可以使用。 實際上，所需的代碼是簡單代碼大小的10倍以上。

我為多個合並的單元格的“自動適合行高”添加了插件。 如果要自動調整行高，請使用此選項。 ［發布Ver2.6·toowaki / AutoFitRowEx·GitHub] https://github.com/toowaki/AutoFitRowEx/releases/tag/2.6.2