【Excel】VBAで、印刷時に文字が切れないように行高さを設定するサンプル

Excelを使用してセルに長文を入力し、複数行表示にしたデータを印刷すると、文章の下端が切れてしまうことがあります。

その原因と解決方法の基本は次のとおりで、標準フォントで調整が必要。

shikumika.org

しかし、複数のフォントを使用していたり標準フォントを変更したくないケース、セル結合があるケースは、上記の解決方法だけでは十分に対応できません。

結果、何十ページにもわたる長文（フリーコメント）の一覧を印刷物としてアウトプットするときは、チェック時間が長くなる。

なので、VBAで、行高さを自動設定するサンプルを作成してみた備忘録。

（行高さのオートフィットでは対応できないケース用。セル毎のフォントの設定、改行文字の有無などをチェックしている）

念のため、原本はバックアップとしてそのまま残す。

選択した範囲に対して実行するので、誤った範囲を選択しないように要注意。

VBAで、行高さを自動設定するサンプル

Option Explicit

Dim 列幅倍率 As Double
Dim 行高さ倍率 As Double
Dim 行余白 As Double

Sub 文字数計算による行高さ補正()

    Dim 選択範囲 As Range
    Dim 対象セル As Object
    Dim 調整前高さ As Double
    Dim 調整後高さ As Double
    Dim i As Long
    
    Application.ScreenUpdating = False '高速化のため、画面更新を停止'
    
    '初期値'
    列幅倍率 = ThisWorkbook.Sheets("設定").Cells(2, 3).Value
    行高さ倍率 = ThisWorkbook.Sheets("設定").Cells(3, 3).Value
    行余白 = ThisWorkbook.Sheets("設定").Cells(4, 3).Value
    
    Set 選択範囲 = Selection

    For Each 対象セル In 選択範囲
          
        調整前高さ = 対象セル.Rows.RowHeight '単位はポイント'
        調整後高さ = 行高さ(対象セル)
        
        '調整前（もともとの高さ）と調整後の高さを比較し、大きい方を残す。'
        調整後高さ = WorksheetFunction.Max(調整前高さ, 調整後高さ)
            
        If 対象セル.MergeCells Then
            調整後高さ = WorksheetFunction.Round(調整後高さ / 対象セル.MergeArea.Rows.Count, 1)
            For i = 1 To 対象セル.MergeArea.Rows.Count
                If 対象セル.MergeArea.Item(i).RowHeight < 調整後高さ Then
                    対象セル.MergeArea.Item(i).RowHeight = 調整後高さ
                End If
            Next
        Else
            対象セル.Rows.RowHeight = 調整後高さ
        End If
                    
    Next

    Application.ScreenUpdating = True

End Sub


Function 行高さ(判定セル As Object)
    Dim 文字間隔 As Double
    Dim セル幅 As Double
    Dim 一行の文字数 As Long
    
    Dim 検索の開始位置 As Long
    Dim 行数 As Long
    Dim 次の改行位置 As Long
    Dim 残り文字数 As Long
        
    '初期値設定'
    文字間隔 = 判定セル.Font.Size * 列幅倍率
    セル幅 = 判定セル.Columns.Width '単位ポイント'
    一行の文字数 = Round(セル幅 / 文字間隔, 0)
    検索の開始位置 = 1
    行数 = 0
    
    '文章の解析'
    Do
        次の改行位置 = InStr(検索の開始位置, 判定セル.Value, vbLf)
        
        If 次の改行位置 = 0 Then  '0なら改行が無いということ'
            残り文字数 = Len(判定セル) - 検索の開始位置
            行数 = 行数 + WorksheetFunction.RoundUp(残り文字数 / 一行の文字数, 0)
            Exit Do
        Else
            行数 = 行数 + WorksheetFunction.RoundUp(次の改行位置 / 一行の文字数, 0) '改行位置までの行数'
            検索の開始位置 = 次の改行位置 + 1
        End If
    Loop

    行高さ = 行数 * 判定セル.Font.Size * 行高さ倍率 + 行余白

End Function