行高を適切に（？）調整する(Excel)

印刷時に行が切れてしまわないようにする方法を考えた。

考え方

フォントには、固有の行高がある。単位はポイント。で、Excelの行の高さ（[Range].RowHeightプロパティの値）も単位はポイント。だから、次のような考え方で行けるはず。

フォントの固有の高さを求める
セルの中で一行あたり何文字になるのかを求める
セル内の文字数とか改行回数をもとに何行になるのかを求める
上下の余白を何ポイント取るのか決める

まあ、これでよかろう。

フォントの固有の高さを求める

これは、よくわからんので、使いたいフォントを指定し、使いたいフォントサイズに変えて、行の境目をダブルクリックしてみた。

たとえば、「UD デジタル教科書体 NK-R」で「11ポイント」を指定すると、

f:id:akashi_keirin:20200605181953j:plain

このように、行高は15ポイントになった。まあ、これでよかろう。（もし違っていたら~~教えろ~~教えてください。）

セルの中での一行あたり文字数を調べる

これは、どうすればよいか分からなかったので、数えたｗ

f:id:akashi_keirin:20200605181959j:plain

PDF化して、目視で数えましたとも。だいたい、55とか56とか、その辺ｗ

セル内の文字数とか改行回数をもとに何行になるのかを求める

セル内改行がなかったら楽勝なんだが、セル内改行を加味するとなるとめんどくさい。

次のように考えた。

セル内に改行記号がなかったら、単純に(文字数 \ 一行あたり文字数) + 1でよい。
セル内に改行記号がある場合は、文字列を先頭からスキャンし、一行あたり文字数に達するか、改行文字にぶつかったらカウントアップする

こんな感じ。

「一行あたり文字数に達するか、改行文字にぶつかったらカウントアップする」という処理は、コードを示した方が早いので示す。

リスト１

Private Function getLinesCount( _
             ByVal tgtCell As Range) As Long
  Dim i As Long
  Dim ret As Long
  ret = 1
  Dim cnt As Long
  cnt = 0
  Dim tgtStr As String
  With tgtCell
    tgtStr = .Value
    For i = 1 To Len(tgtStr)
      cnt = cnt + 1
      '改行文字にぶつかったらcntをリセットして行数をイン'
      'クリメント'
      If Mid(tgtStr, i, 1) = vbLf Then
        cnt = 0
        ret = ret + 1
        GoTo Continue
      End If
      'cntが１行あたり文字数に達したらcntをリセットして'
      '行数をインクリメント'
      If cnt Mod chrCntPerLine = 0 Then
        cnt = 0
        ret = ret + 1
      End If
Continue:
    Next
  End With
    getLinesCount = ret
End Function

途中出てくるchrCntPerLineは、一行あたり文字数を入れておく変数。モジュールレベル変数にしているので、宣言がない。決してさんたろう方式ではないので誤解のなきよう。

上下の余白を何ポイント取るのか決める

「決める」といっても、上○ポイント、下○ポイントみたいに決めることは（たぶん）できないので、期待しないように。

垂直方向を中央揃えにしておけば、上下に均等にマージンを入れるぐらいならできる、という意味。

たとえば、行数 × 一行あたりの行高で求めた値に10を足してやれば、上下5ポイントづつマージンができる。ただそれだけだ。

行高を調整するメソッド

めんどくさいので完成したコードを示す。

リスト２　標準モジュール RowHeightUtil

Option Explicit

'Module Level Variables'
Private fntHeight As Single
Private chrCntPerLine As Long
Private tpbtmMargin As Single

'Methods'
Public Sub adjustRowHeight(ByVal targetCell As Range, _
                           ByVal FontHeight As Single, _
                           ByVal CharCountPerLine As Long, _
                           ByVal TopBottomMargin As Single)
  If targetCell.Value = "" Then Exit Sub
  fntHeight = FontHeight
  chrCntPerLine = CharCountPerLine
  tpbtmMargin = TopBottomMargin
  Dim linesCount As Long
  Dim tgtRowHeight As Single
  With targetCell
    'セル内改行がされていなければ、文字数だけで行数を判定する'
    If InStr(1, .Value, vbLf) = 0 Then
      linesCount = (Len(.Value) \ chrCntPerLine) + 1
    'セル内改行があるときは、1文字づつスキャンして行数を判定する'
    Else
      linesCount = getLinesCount(targetCell)
    End If
    tgtRowHeight = (linesCount * fntHeight) + tpbtmMargin
    '親のWorksheetオブジェクトを取得'
    Dim tgtSh As Worksheet
    Set tgtSh = .Parent
    tgtSh.Rows(.Row).RowHeight = tgtRowHeight
  End With
End Sub

Private Function getLinesCount( _
             ByVal tgtCell As Range) As Long
  Dim i As Long
  Dim ret As Long
  ret = 1
  Dim cnt As Long
  cnt = 0
  Dim tgtStr As String
  With tgtCell
    tgtStr = .Value
    For i = 1 To Len(tgtStr)
      cnt = cnt + 1
      '改行文字にぶつかったらcntをリセットして行数をイン'
      'クリメント'
      If Mid(tgtStr, i, 1) = vbLf Then
        cnt = 0
        ret = ret + 1
        GoTo Continue
      End If
      'cntが１行あたり文字数に達したらcntをリセットして'
      '行数をインクリメント'
      If cnt Mod chrCntPerLine = 0 Then
        cnt = 0
        ret = ret + 1
      End If
Continue:
    Next
  End With
    getLinesCount = ret
End Function

行高を調整することに特化したモジュールを作った。