行高を適切に(?)調整する(Excel)

行高を適切に(?)調整する(Excel)

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

考え方

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

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

まあ、これでよかろう。

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

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

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

f:id:akashi_keirin:20200605181953j:plain

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

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

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

f:id:akashi_keirin:20200605181959j:plain

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

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

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

次のように考えた。

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

こんな感じ。

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

リスト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が1行あたり文字数に達したら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ポイントづつマージンができる。ただそれだけだ

行高を調整するメソッド

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

スト2 標準モジュール 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が1行あたり文字数に達したらcntをリセットして'
      '行数をインクリメント'
      If cnt Mod chrCntPerLine = 0 Then
        cnt = 0
        ret = ret + 1
      End If
Continue:
    Next
  End With
    getLinesCount = ret
End Function

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

使ってみる

f:id:akashi_keirin:20200605182015g:plain

こんなふうにして行高を調整しても、画面上ではきれいにととのっているが、PDF化(印刷)してみると、

f:id:akashi_keirin:20200605182004j:plain

この体たらく。とほほ。

それが!

上記メソッドを用いて処理すると、

f:id:akashi_keirin:20200605182028g:plain

こうなって、PDF化(印刷)してみると、

f:id:akashi_keirin:20200605182010j:plain

バッチリ!

おわりに

だいぶまえにちゅん氏(id:Kotori-ChunChun)もやっていたような気がするので、勉強しに行きます。