Excelマクロ・行の高さを自動調整する方法

質問

• Excelの人材情報リストから特定の行の高さを自動調整する方法についてご質問です。
• VLOOKUP関数を使用しているため行の自動調整ができない問題があります。
• VBAを使用してマクロを作成することで高さの調整が可能です。

回答No.4

real beatin（@realbeatin）

＃１-２です。＃１補足コメント拝見しました。

> うまくいきませんでした。
行高の[自動調整]が出来なかった、ということで宜しいですか？

補足の内容をみて原因となり得る特異点は、ただ一つ、
[結合セル]の行高を[自動調整]しようとしていることです。
Excel本来の仕様として[結合セル]に対しては
[自動調整]は機能しません。
なので、Excelの機能に期待せず、自力実装することになります。
簡単ではないですね。

行の高さを計算で求めるのは、パラメータが多過ぎて困難ですから、
作業列を使って、
作業セル（単セル）の実効幅を結合セルの実行幅（計算で求める）に合わせ、
フォントの各設定を合わせ、値をトレースし、
[折り返して全体を表示する]行高[自動調整]を
作業セルでシミュレートした高さを該当行の高さとして確定します。

何が難しいって、[結合セル]が難しいので、
下に書いたマクロは専ら[結合セル]に対して行の高さをすべて
Excelの[自動調整]仕様に合わせる、というものです。
[結合セル]以外に対しては全く処理しません（＃１-２を参考にして下さい）。

もし、高さを変えたくない[結合セル]があれば、
処理対象セル範囲の指定方法を工夫して除外するようにしてください。

本当は、、、
行高の[自動調整]をしたい[結合セル]が、
何処と何処、、、にあるとかの情報があれば、
もうちょっぴり簡単に書けたかも知れません。

ここに挙げるマクロをお使いのマクロのどのタイミングで実行するか、
ですが、
Sheet1の印刷に関する設定変更等を、ループ中に、
シート毎に処理している場合は、その直前。
'人材番号をA１セルに入力し'た後、
その他、セルやシートの各種設定を、
ループ中に、シート毎に処理している場合は、その後、になります。

以下、こちらの環境では問題なく動いてますが、
もし、何か不足があれば、具体的に書いてくだみてくださいね。
◆でマークしている３か所は、それぞれ引数をそちらで適宜指定（または確認）してください。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub Re8919629()
Const S = "Sheet1"　'　要指定◆シート名は正確に◆
Dim rWork As Range　'　作業セル範囲
Dim c As Range　'　ループ用の[各セル]
Dim cnCol As Long　'　処理件数

　　If ActiveSheet.Name <> S Then Sheets(S).Select　'　処理対象シートを確実に選択しておく
　　With ActiveSheet.UsedRange　'　処理対象シートの内、使用中の範囲を捉える
　　　　' ' 要指定◆一時的な作業列としてそれより右すべてが使用可能な列を指定（例ではＪ列）◆
　　　　' ' ◆但し、作業列は必ず印刷範囲の外であること◆
　　　　' ' 作業セルを必要な行数に限定した範囲として変数に格納
　　　　Set rWork = Columns("J").Resize(.Rows(.Rows.Count).Row)
　　End With

　　Application.ScreenUpdating = False　'　処理が遅くならないように描画停止
　　On Error GoTo ErrH_　'　エラートラップ
　　' ' 処理対象セル範囲の[各セル]を総当たりでループ
　　cnCol = 0　'　初期化
　　For Each c In Range("E1:E50")　'　要指定◆処理対象セル範囲をRange型で指定◆余裕をもって大きめに指定してもＯＫ
　　　　If c.MergeCells Then　'　[各セル]が結合だったら
　　　　　　If c.Address = c.MergeArea(1).Address Then　'　[各セル]が結合セル範囲の左上だったら
　　　　　　　　If Not c.WrapText Then c.WrapText = True　'　[各セル][折り返して全体を表示する]設定の徹底
　　　　　　　　cnCol = cnCol + 1　'　処理する数をカウント
　　　　　　　　With rWork.Cells(c.Row, cnCol)　'　[各セル]と同じ行　未使用の作業列にあるセルを作業セルとして
　　　　　　　　　　.ColumnWidth = (c.MergeArea.Width * 4 / 3 - 5) / 8　'　作業セルの有効幅を[各セル]に合わせる
　　　　　　　　　　.Font.Name = c.Font.Name　'　作業セルのフォント設定各種を[各セル]に合わせる
　　　　　　　　　　.Font.Size = c.Font.Size
　　　　　　　　　　.Font.Bold = c.Font.Bold
　　　　　　　　　　.Value = c.Value　'　作業セルの値を[各セル]の値を定数化したものに設定
　　　　　　　　　　.WrapText = True　'　作業セルを[折り返して全体を表示する]設定
　　　　　　　　　　.EntireRow.AutoFit　'　作業セルの行高を[自動調整]
　　　　　　　　End With
　　　　　　　　c.RowHeight = c.RowHeight　'　作業セルが規定する行高を確定する
　　　　　　End If
　　　　End If
　　Next
　　rWork.Resize(, cnCol).Clear　'　作業セルをクリア
'　　rWork.Resize(, cnCol).Delete Shift:=xlShiftToLeft　'　作業セルを削除
　　ActiveSheet.UsedRange　'　印刷範囲を変えないようにUsedRange を元に戻す。
ErrH_:
　　If Err Then MsgBox "エラー：" & Err.Number & vbLf & Err.Description　'　エラー時のメッセージ
　　Application.ScreenUpdating = True　'　描画再開
End Sub

補足

ご丁寧なご回答ありがとうございます。なんだかとても難しそうですね…。
横（列）には結合していますが、縦（行）は結合していないので、問題がないと思っていました。

記述頂いたものをコピペして要指定◆の三か所を、
(1)Const S = "プロフィールシート"
(2)Set rWork = Columns("V").Resize(.Rows(.Rows.Count).Row)
(3)For Each c In Range("J13:T13")　'　※試しに結合しているセル範囲J13：T13を入力してみました※
と変えて実行してみましたが、「エラー：1004アプリケーション定義またはオブジェクト定義のエラーです」というメッセージが出ました。

ちなみに、行の高さを自動調整したい結合セルは、F9:T9、F13:T13、F21:T21、F22:T22、F23:T23の５か所です。

印刷ボタンに登録したマクロも念のために記します。
もしよろしければ、またご教授ください。
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
Private Sub 印刷開始_Click()
Dim 番号 As Integer
a = TextBox1.Value
n = TextBox2.Value　'プリンタの選択後、印刷またはキャンセル
Dim BlnRtn As Boolean
BlnRtn = Application.Dialogs(xlDialogPrinterSetup).Show
Select Case BlnRtn
Case True
For 番号 = a To n
Sheets("プロフィールシート").Range("A1").Value = 番号
Sheets("プロフィールシート").PrintOut
Next 番号
Case False
MsgBox "印刷はキャンセルされました。"
End Select
Unload Me
End Sub