結合したセルの高さを自動調節する(縦方向の結合にも対応)

縦方向の結合にも対応させてみたが思ったより大げさになってしまった。

Option Explicit

'結合したセルの高さを自動調節する
'
' 処理の概要
' - 新しいブックを作成し、書式、標準のフォントとそのサイズを選択したセル範囲からコピー
'   (標準のフォントの大きさによって長さ当たりのピクセル数が変わってくるので標準のフォントを揃えること重要)
' - 結合したセル範囲の一覧を作成しDictionaryObjectに保存する
' - 結合したセル範囲を一つずつ取り出しテスト用のセルにコピーする
' - テスト用のセルを結合後の幅に揃えたうえでAutoFitする。
' - テスト用セルの高さと現在の高さを比べて高いほうに高さを設定する。
Sub AutofitMergedCells()
    AutofitMergedCells_ Selection
End Sub


Private Sub AutofitMergedCells_(Target As Range)
    '自動調節したいセル範囲、ブック等を変数に格納 =>TargetBook
    Dim TargetBook As Workbook
    Set TargetBook = Target.Worksheet.Parent
    Dim NormalFontName As String
    NormalFontName = TargetBook.Styles("Normal").Font.Name ' 後で取得するとなぜかMSゴシックが返ってくるので最初に取得しておく
    Dim NormalFontSize As Double
    NormalFontSize = TargetBook.Styles("Normal").Font.Size
    
    
    '高さを調べるためのテスト用ブックの用意 =>TestBook    '
    Dim TestBook As Workbook
    Set TestBook = Workbooks.Add
    Dim TestSheet As Worksheet
    Set TestSheet = TestBook.Worksheets(1)
    Dim TestCell As Range
    Set TestCell = TestSheet.Cells(1, 1)
    'テストブックのNormalスタイル
    TestBook.Styles("Normal").Font.Name = NormalFontName
    TestBook.Styles("Normal").Font.ThemeFont = xlThemeFontNone
    TestBook.Styles("Normal").Font.Size = NormalFontSize

    Dim tmpRow As Range
    For Each tmpRow In Target.Rows
        tmpRow.AutoFit
    Next
    
    Dim Areas As New Scripting.Dictionary
    Set Areas = MergedAreas(Target)
    Dim k
    For Each k In Areas.Keys
        Dim Area As Range
        Set Area = Areas(k)
        
        Dim RemainHeight As Double
        RemainHeight = HeightToFit(Area, TestCell)
        Dim RowHeight As Double
        
        Dim Row As Range
        Dim Index As Long
        Index = 1
        While 0 < RemainHeight
            RowHeight = RemainHeight / (Area.Rows.Count - Index + 1)
            Set Row = Area.Rows(Index)
            If Row.RowHeight < RowHeight Then
                Row.RowHeight = RowHeight
            End If
            RemainHeight = RemainHeight - Row.RowHeight
            Index = Index + 1
        Wend
        
Continue_:
    Next
    TestBook.Close False
End Sub

'結合したセルをAutoFitした場合の高さ
Private Function HeightToFit(Area As Range, TestCell As Range)
    Dim Row As String
    Dim MergedAreas As New Scripting.Dictionary
    Dim c As Range
    For Each c In Area.Cells
        If Not MergedAreas.Exists(c.MergeArea.Address) Then
            MergedAreas.Add c.MergeArea.Address, c.MergeArea
        End If
    Next
    
    Dim MergedCells
    
    
    HeightToFit = 0
    For Each MergedCells In MergedAreas.Items
        
        Dim MergedWidth As Double
        MergedWidth = 0
        Dim Col As Range
        For Each Col In MergedCells.Columns
            MergedWidth = MergedWidth + Col.ColumnWidth
        Next
        MergedWidth = MergedWidth
        MergedCells.Copy
        TestCell.Worksheet.Paste TestCell
    
        TestCell.MergeCells = False
        TestCell.ColumnWidth = MergedWidth
        TestCell.Value = MergedCells.Value
        
        TestCell.EntireRow.AutoFit
        HeightToFit = IIf(HeightToFit < TestCell.RowHeight, TestCell.RowHeight, HeightToFit)
    Next
End Function


Private Function MergedAreas(Range As Range) As Scripting.Dictionary
    Dim Dict As New Dictionary
    Dim Cell As Range
    For Each Cell In Range
        If Cell.MergeCells And Not Dict.Exists(Cell.MergeArea.Address) Then
            Dict.Add Cell.MergeArea.Address, Cell.MergeArea
        End If
    Next
    Set MergedAreas = Dict
End Function