[Excel] 結合セルを含んだ行の高さを自動調整するVBA
- Next Page: CentOSにGRUB2を入れる
- Prev Page: ThunderbirdでURLをクリックしてもブラウザが開かなくなった場合の対処
Excelの仕様で、結合セルを含んだ行に対しては、高さの自動調整がうまく動作しません。
VBAではRangeオブジェクトにAutoFitメソッドがありますが、これも結合セルでは同じく正常に動作しません。
それを解決するVBAを作りました。といっても、元ネタは以下のページのコードです。
エクセルで結合したセルの高さの自動調整方法？(1/1) | OKWave
いくつか改善したポイントがあります。
- 行全体選択、列全体選択、シート全体選択時でも、処理対象セルが膨大にならないように UsedRange プロパティで範囲を限定。
- 結合セルに対する重複処理を省き、全体処理数を削減。
- マージンを設定可能（+1行分を足すなど）
自由にお使いください。
Option Explicit
Public Enum AutoFitDirection
enmColumn '列
enmRow '行
End Enum
Private Const vbShiftMask As Integer = 1 'キーコードマスク定数。(システム定数にないため、ユーザー定義)
Private Const vbCtrlMask As Integer = 2 ' 〃
'↓実行時エラーコード。
Private Const pErrOutOfIndex As Long = 9 'インデックスが有効範囲にありません。
Private Const pErrFileNotFnd As Long = 53 'ファイルが見つかりません。
Private Const pErrCreateObj As Long = 429 'CreateObject | GetObject (インスタンスの生成) に失敗。
Private Const pErrPrinterNotAvailable As Long = 2212 'プリンタが無効です。
Private Const pErrReadMdl As Long = 2601 'モジュールの読み取り権限がない。
Private Const pErrUseObj As Long = 3033 'オブジェクト <オブジェクト名> を使用する権限がありません。
Private Const pErrReadObj As Long = 3110 'テーブルまたはクエリー <名前> の定義を読み取る権限がないため、定義を読み取ることができませんでした。
Private Const pErrPrpNotFnd As Long = 3270 'プロパティが見つかりません。
Private Const pErrCantReadJetDb As Long = 3343 'データベースを認識できません。
Private Const pErrMdlNotFnd As Long = &H8007007E '指定されたモジュールが見つかりません。
Private Const xlsMaxColumns As Long = &H100& 'Excelシートで利用可能な最大列数
Private Const xlsMaxRows As Long = &H10000 'Excelシートで利用可能な最大行数
'Excel列座標変換ユーティリティ
Private Function GetXlsPosYStr(ByVal lngPos As Long) As String
'Excelの横座標数値(1～256)を文字列("A" ～ "IV")に変換。
Select Case lngPos
Case 1 To 26
GetXlsPosYStr = Chr$(lngPos + 64)
Case 27 To xlsMaxColumns
GetXlsPosYStr = Chr$((lngPos - 1) \ 26 + 64) & Chr$((lngPos - 1) Mod 26 + 65)
Case Else
Err.Raise pErrOutOfIndex
End Select
End Function
Private Function GetXlsPosYLong(ByVal strPos As String) As Long
'Excelの横座標文字列("A" ～ "IV")を数値(1～256)に変換。
Dim lngPos As Long
strPos = UCase$(Trim$(strPos))
Select Case Len(strPos)
Case 1
lngPos = Asc(strPos) - 64
Case 2
lngPos = (Asc(Left$(strPos, 1)) - 64) * 26 + Asc(Right$(strPos, 1)) - 64
If lngPos > xlsMaxColumns Then
Err.Raise pErrOutOfIndex
End If
Case Else
Err.Raise pErrOutOfIndex
End Select
GetXlsPosYLong = lngPos
End Function
Sub AutoFitEx()
Const keepDefault = True
Dim r, row, rngTarget As Range
Dim hAlign, vAlign As Excel.Constants
Dim strAddress As String
Dim strTmp As String
Dim strStClmn, strEdClmn As String
Dim lngStClmn, lngEdClmn, lngStRow, lngEdRow As Long
Dim lngPos As Long
Dim lngRowHeight As Long
Dim strRowMargin As String
Dim lngRowMargin As Double
Dim clmnWdthSum As Double
Dim StClmnWdth As Double
Dim orgClmnWdth As Double
Dim RowHghtSum As Double
Dim StRowHght As Double
Dim orgRowHght As Double
Dim i, j, jmax, cnt As Long
Dim tblAddress() As String 'アドレステーブル : 結合セルに対する処理の重複を防ぐ配列
Dim msg As String
Set rngTarget = Application.Intersect(Selection, ActiveSheet.UsedRange)
If rngTarget.Cells.Count >= 10000 Then
msg = "選択範囲が大きすぎるため、実行を中止します。" & vbNewLine & "行選択、列選択、全体選択は使用せず、必要な範囲だけを選択するようにしてください。"
Call MsgBox(msg, vbOKOnly)
Exit Sub
ElseIf rngTarget.Cells.Count >= 3000 Then
msg = "多くのセル以上が選択されており、処理に時間がかかる可能性があります。" & vbNewLine & "実行しますか？"
If MsgBox(msg, vbYesNo) = vbNo Then
Exit Sub
End If
End If
msg = "行高さの余裕分(マージン)を指定してください。" & vbNewLine & "単位:ポイント, デフォルト:一行分"
strRowMargin = InputBox(prompt:=msg, title:="マージン入力", Default:=13.5)
If strRowMargin = "" Then Exit Sub
lngRowMargin = CDbl(strRowMargin)
'画面更新を停止
Application.ScreenUpdating = False
jmax = -1
For Each r In rngTarget
hAlign = r.HorizontalAlignment
vAlign = r.VerticalAlignment
strAddress = r.MergeArea.Address(ReferenceStyle:=xlA1)
'アドレステーブルにあるかチェック
j = 0
Do While j <= jmax
If tblAddress(j) = strAddress Then
Exit Do
End If
j = j + 1
Loop
'アドレステーブルにあるセル(結合セルの重複セル)は処理しない
If j > jmax Then
'アドレステーブルに追加
jmax = j
ReDim tblAddress(jmax)
tblAddress(jmax) = strAddress
'セル（結合セル）の上下端の行番号、左右端の列番号取得
strStClmn = Mid$(strAddress, 2)
strTmp = Mid$(strStClmn, InStr(strStClmn, "$") + 1)
lngPos = InStr(strTmp, ":")
If lngPos <> 0 Then
lngStRow = CLng(Left$(strTmp, lngPos - 1))
lngEdRow = CLng(Mid$(strAddress, InStrRev(strAddress, "$") + 1))
Else
lngStRow = CLng(Mid$(strStClmn, InStr(strStClmn, "$") + 1))
lngEdRow = lngStRow
End If
strStClmn = Left$(strStClmn, InStr(strStClmn, "$") - 1)
strEdClmn = Mid$(strAddress, InStr(strAddress, ":") + 2)
strEdClmn = Left$(strEdClmn, InStr(strEdClmn, "$") - 1)
lngStClmn = GetXlsPosYLong(strStClmn)
lngEdClmn = GetXlsPosYLong(strEdClmn)
With ActiveSheet
'セルの結合解除
r.UnMerge
'全カラムの合計幅を計算
clmnWdthSum = 0
For i = lngStClmn To lngEdClmn
clmnWdthSum = clmnWdthSum + .Columns(i).ColumnWidth
Next i
'左端のカラム幅を一時変数に格納
StClmnWdth = .Columns(lngStClmn).ColumnWidth
'左端のカラム幅を全カラムの合計値に設定
.Columns(lngStClmn).ColumnWidth = clmnWdthSum
'AutoFitを使って必要な高さを取得
orgRowHght = .Rows(lngStRow).RowHeight
.Rows(lngStRow).AutoFit
lngRowHeight = .Rows(lngStRow).RowHeight
.Rows(lngStRow).RowHeight = orgRowHght
'左端のカラム幅を元に戻す
.Columns(lngStClmn).ColumnWidth = StClmnWdth
For Each row In r.Rows
'オリジナルの高さを格納
orgRowHght = row.RowHeight
'按分した高さを適用
row.RowHeight = lngRowHeight / (lngEdRow - lngStRow + 1) + lngRowMargin
'AutoFitで調整された高さよりオリジナルが高ければ、オリジナルで再適用する
If keepDefault Then
If row.RowHeight < orgRowHght Then
row.RowHeight = orgRowHght
End If
End If
Next row
'セルの再結合
With .Range(strAddress)
.Merge
.HorizontalAlignment = hAlign
.VerticalAlignment = vAlign
End With
End With
End If
Next r
Application.ScreenUpdating = True
End Sub
トラックバック(0)
トラックバックを送る際には、この記事へのリンクを記事内につけてください。
トラックバックはありません。
コメント(0)
コメントはありません。
コメントを投稿してください。