Excel VBA 結合セルの行の高さをテキストボックスを使って自動調整する

はじめに

エクセルでは結合したセルの行の高さを自動調整することができない。
そのため、VBAを使って自動調整を行う方法について考えたい。

作成したいマクロのイメージ

結合セルの列幅を取得する。
その列幅で、結合していないセルで自動調整した場合の行の高さを取得する。
取得した行の高さを結合セルに適用する。
この動作をなるべく簡潔なコードで実現したい。

作成したマクロの概要

模索した結果、テキストボックスを使用する方法で作成することにした。
セルとテキストボックスでは、自動調整時の高さに誤差があるが、許容範囲内と判断した。

動作手順

1. テキストボックスを用意する
2. 結合セルのデータをテキストボックスに入力する
3. 結合セルのフォント、フォントサイズをテキストボックスに適用する
4. テキストボックスのサイズをテキストに合わせて調整する
5. 結合セルの高さとサイズを調整したテキストボックスの高さを比較する
6. テキストボックスの高さより結合セルの高さが低い場合、セルの高さを調節する

作成時に考慮したこと

• テキストボックスの上下左右の余白を5で指定し、自動調整時の高さの誤差を少なくした
• 縦に結合しているセルがある場合、1行目以降のセルも調整する対応を考えた
• セルの高さの調整時、セルの高さの最大値(409.5)を超えた場合の対応を考えた

完成したマクロ

MergedCellsRowAutoFit

Public Sub MergedCellsRowAutoFit()

Dim obj As Shape
Dim TargetRange As Range
Dim iRange As Range
Dim AdjustHeight As Double

    Application.ScreenUpdating = False

    With ActiveSheet   
        Set obj = .Shapes.AddLabel(msoTextOrientationHorizontal, 100, 100, 100, 100)
        Set TargetRange = .Range(.Range("A1"), .Range("A1").SpecialCells(xlCellTypeLastCell))
    End With

    obj.TextFrame2.MarginTop = 5
    obj.TextFrame2.MarginBottom = 5
    obj.TextFrame2.MarginLeft = 5
    obj.TextFrame2.MarginRight = 5

    TargetRange.EntireRow.AutoFit
    
    For Each iRange In TargetRange
    
        If iRange.MergeArea.Count = 1 Then

            If iRange.Value <> "" Then
                obj.TextFrame2.TextRange.Text = iRange.Value
            End If
            
        Else
        
            If iRange.MergeArea.Value2(1, 1) <> "" Then
                obj.TextFrame2.TextRange.Text = iRange.MergeArea.Value2(1, 1)
            End If
            
        End If


        If obj.TextFrame2.TextRange.Text <> "" Then
        
            obj.Width = iRange.MergeArea.Width
            obj.TextFrame2.TextRange.Font.Name = iRange.Font.Name
            obj.TextFrame2.TextRange.Font.NameFarEast = iRange.Font.Name
            obj.TextFrame2.TextRange.Font.Size = iRange.Font.Size
            obj.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
            
            If iRange.MergeArea.Height < obj.Height Then
            
                AdjustHeight = iRange.RowHeight + obj.Height - iRange.MergeArea.Height  
                
                If AdjustHeight <= 409.5 Then
                    iRange.RowHeight = AdjustHeight
                Else
                    iRange.RowHeight = 409.5
                End If
                
            End If
            
        End If
        
        obj.TextFrame2.TextRange.Text = ""
    
    Next iRange
    
    obj.Delete
    Set obj = Nothing
          
    Application.ScreenUpdating = True
    
End Sub

サンプルファイル保存先：