エクセルで結合したセルの高さの自動調整方法？

自前のコードを書くしかないようです。

一例ですが、参考までに・・・。

'定数定義
Option Explicit

Public Const vbShiftMask As Integer = 1 'キーコードマスク定数。(システム定数にないため、ユーザー定義)
Public Const vbCtrlMask As Integer = 2 ' 〃

'↓実行時エラーコード。
Public Const pErrOutOfIndex As Long = 9 'インデックスが有効範囲にありません。
Public Const pErrFileNotFnd As Long = 53 'ファイルが見つかりません。
Public Const pErrCreateObj As Long = 429 'CreateObject | GetObject (インスタンスの生成) に失敗。
Public Const pErrPrinterNotAvailable As Long = 2212 'プリンタが無効です。
Public Const pErrReadMdl As Long = 2601 'モジュールの読み取り権限がない。
Public Const pErrUseObj As Long = 3033 'オブジェクト <オブジェクト名> を使用する権限がありません。
Public Const pErrReadObj As Long = 3110 'テーブルまたはクエリー <名前> の定義を読み取る権限がないため、定義を読み取ることができませんでした。
Public Const pErrPrpNotFnd As Long = 3270 'プロパティが見つかりません。
Public Const pErrCantReadJetDb As Long = 3343 'データベースを認識できません。
Public Const pErrMdlNotFnd As Long = &H8007007E '指定されたモジュールが見つかりません。

Public Const xlsMaxColumns As Long = &H100& 'Excelシートで利用可能な最大列数。
Public Const xlsMaxRows As Long = &H10000 ' 〃 最大行数。


'Excel列座標変換ユーティリティ
Option Explicit

Public 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

Public 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


'AutoFitの拡張版。(結合セルに対応)
Option Explicit

Public Enum AutoFitDirection
enmColumn '列
enmRow '行
End Enum

Public Function AutoFitEx( _
ByRef wksht As Excel.Worksheet, _
ByRef rngTarget As Excel.Range, _
Optional ByVal Direction As AutoFitDirection = enmRow, _
Optional ByVal keepDefault As Boolean = True)

Dim hAlign As Excel.Constants
Dim vAlign As Excel.Constants
Dim strAddress As String
Dim strTmp As String
Dim strStClmn As String
Dim strEdClmn As String
Dim lngStClmn As Long
Dim lngEdClmn As Long
Dim lngStRow As Long
Dim lngEdRow As Long
Dim lngPos As Long
Dim i As Long
Dim clmnWdthSum As Double
Dim StClmnWdth As Double
Dim orgClmnWdth As Double
Dim RowHghtSum As Double
Dim StRowHght As Double
Dim orgRowHght As Double

hAlign = rngTarget.HorizontalAlignment
vAlign = rngTarget.VerticalAlignment

strAddress = rngTarget.MergeArea.Address(ReferenceStyle:=xlA1)
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)

rngTarget.UnMerge

With wksht
If Direction = enmRow Then
'高さの自動調整
StClmnWdth = .Columns(lngStClmn).ColumnWidth
clmnWdthSum = 0

For i = lngStClmn To lngEdClmn
clmnWdthSum = clmnWdthSum + .Columns(i).ColumnWidth
Next i

.Columns(lngStClmn).ColumnWidth = clmnWdthSum
orgRowHght = .Rows(lngStRow).RowHeight
.Rows(lngStRow).AutoFit

If keepDefault Then
If .Rows(lngStRow).RowHeight < orgRowHght Then
.Rows(lngStRow).RowHeight = orgRowHght
End If
End If

.Columns(lngStClmn).ColumnWidth = StClmnWdth
Else
'幅の自動調整
StRowHght = .Rows(lngStRow).RowHeight
RowHghtSum = 0

For i = lngStRow To lngEdRow
RowHghtSum = RowHghtSum + .Rows(i).RowHeight
Next i

.Rows(lngStRow).RowHeight = RowHghtSum
orgClmnWdth = .Columns(lngStClmn).ColumnWidth
.Columns(lngStClmn).AutoFit

If keepDefault Then
If .Columns(lngStClmn).ColumnWidth < orgClmnWdth Then
.Columns(lngStClmn).ColumnWidth = orgClmnWdth
End If
End If

.Rows(lngStRow).RowHeight = StRowHght
End If

With .Range(strAddress)
.Merge
.HorizontalAlignment = hAlign
.VerticalAlignment = vAlign
End With
End With
End Function

投稿日時 - 2005-05-12 10:44:39