ついに解決！！エクセルで行の高さを自動調整するマクロ_evolution
2022年06月24日
エクセルで印刷するときの見切れ対策として、
過去の記事「エクセルで行の高さを１行分バッファをもって自動調整する」で
自動高さ調整→15pt程度余白ができるよう高さ調整するマクロを紹介した。
エクセルで印刷すると文字サイズが見た目より若干大きなる。
１行分の余白を入れて、見切れを防止する内容ではあるけど、
セルの文字数が多くなると、やっぱり見切れる。。。
問題なのは文字サイズ。文字サイズ！？
今までなんで気づかなかったんだろう。
文字サイズが問題なら文字サイズを変えて自動調整すればいいことに。。。
今回はその対策方法について紹介する。
手順
１．見切れが発生しそうなセルを選択し、文字サイズを１レベル大きくする。
２．高さの自動調整をする。
３．大きくした文字サイズを元に戻す。
これならマクロ使わずに手動でできる。
でもめんどくさいので、やっぱりマクロでｗ
フォントサイズはrange.font.sizeで取得・設定ができる。
選択範囲の文字サイズをnポイント大きくするプロシージャを用意。
1ポイント大きくしてから、高さの自動調整をして、1ポイント小さくする。
印刷時に何ポイント分 文字が大きくなるか、
使っているフォントによって変わるかもしれないので、
実行時にInputBoxでポイントを指定する仕様にした。
実行前後のtimer関数の差分で、フォントサイズ変更の処理時間を計測
もう少し高速処理して欲しいところだけど、
そんなに大量に印刷しないだろうからこんなものか。
大きさを変えない場合：170,036セルを21.879秒で実行
大きさを変えた場合 ：170,036セルを34.703秒で実行
描画を消して試したところ、フォントを小さくする場合は
大きさを変えない場合：170,036セルを25.078秒で実行
小さくした場合：170,036セルを25.418秒で実行
大きくした場合：待ちきれず強制終了。(5分で11,000セル）
以下、ソース。ソーステキストは、 こちらからダウンロード。
過去の記事「エクセルで行の高さを１行分バッファをもって自動調整する」で
自動高さ調整→15pt程度余白ができるよう高さ調整するマクロを紹介した。
エクセルで印刷すると文字サイズが見た目より若干大きなる。
１行分の余白を入れて、見切れを防止する内容ではあるけど、
セルの文字数が多くなると、やっぱり見切れる。。。
問題なのは文字サイズ。文字サイズ！？
今までなんで気づかなかったんだろう。
文字サイズが問題なら文字サイズを変えて自動調整すればいいことに。。。
今回はその対策方法について紹介する。
手順
１．見切れが発生しそうなセルを選択し、文字サイズを１レベル大きくする。
２．高さの自動調整をする。
３．大きくした文字サイズを元に戻す。
これならマクロ使わずに手動でできる。
でもめんどくさいので、やっぱりマクロでｗ
フォントサイズはrange.font.sizeで取得・設定ができる。
選択範囲の文字サイズをnポイント大きくするプロシージャを用意。
1ポイント大きくしてから、高さの自動調整をして、1ポイント小さくする。
印刷時に何ポイント分 文字が大きくなるか、
使っているフォントによって変わるかもしれないので、
実行時にInputBoxでポイントを指定する仕様にした。
実行前後のtimer関数の差分で、フォントサイズ変更の処理時間を計測
もう少し高速処理して欲しいところだけど、
そんなに大量に印刷しないだろうからこんなものか。
大きさを変えない場合：170,036セルを21.879秒で実行
大きさを変えた場合 ：170,036セルを34.703秒で実行
描画を消して試したところ、フォントを小さくする場合は
大きさを変えない場合：170,036セルを25.078秒で実行
小さくした場合：170,036セルを25.418秒で実行
大きくした場合：待ちきれず強制終了。(5分で11,000セル）
以下、ソース。ソーステキストは、 こちらからダウンロード。
Sub ◆selection_行の高さを自動調節_改()
'InputBox で 自動調整時に何pt大きくするか指定
Dim inputMsg As String: inputMsg = "選択行の高さを自動調整します。サイズのバッファを入力してください。"
Dim sizeBuf: sizeBuf = InputBox(inputMsg, "sizeBufを入力", 1)
If IsNumeric(sizeBuf) = False Or sizeBuf < 0 Then _
Call errorEnd("サイズバッファは、0以上の整数で指定してください。")
Dim strRows As String
strRows = Selection(1).Row & ":" & Selection(Selection.Count).Row
Application.ScreenUpdating = False
If sizeBuf <> 0 Then Call selection_makeFontBigger(sizeBuf) 'n pt大きく
Rows(strRows).AutoFit '行の高さを自動調節
If sizeBuf <> 0 Then Call selection_makeFontBigger(-sizeBuf) 'n pt小さく
Application.ScreenUpdating = True
End Sub
Private Sub selection_makeFontBigger(pt)
Dim r As range
For Each r In Selection
r.Font.Size = r.Font.Size + pt
Next r
End Sub
'エラー発生時にメッセージを出力して終了させる
Private Sub errorEnd(msg)
Application.ScreenUpdating = True 'おまじない
MsgBox msg
End
End Sub
Private Sub testSpeed()
Dim tictoc: tictoc = Timer()
Dim sizeBuf: sizeBuf = 1
'Application.ScreenUpdating = False
Call selection_makeFontBigger(sizeBuf)
Application.ScreenUpdating = True
tictoc = Format(Timer() - tictoc, "0.000")
Debug.Print "sizeBuf=" & sizeBuf & " | " & Format(Selection.Count, "#,##0") & "セルを" & tictoc & "秒で実行"
End Sub
PR
Comment