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

質問

エクセル2000、Win2000です。

いくつかのセルを横に結合し、セル内で「折り返して全体を表示する」にしています。
セルを結合してない場合は、入力文字数が多くなっても行の高さを自動調整にすれば、ちゃんと折り返して全部表示されますが、結合したセルの場合は、自動調整がきかず、
いちいち手動で調整しなくてはいけません。

１．結合セルでも自動調整する方法はないですか？
２．ない場合、VBAで行の高さを変えてみようと思いますが、セル内で折り返しているかどうか、および何行に折り返されているかはどう判別すればいいでしょうか？

回答No.1

BuXiangHua · ベストアンサー

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

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

'定数定義
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

お礼

さっそくありがとうございます。
ものすごい大仕掛けが必要になりますねえ！！！
目が回りそうです（笑）

勉強させていただきます。
ありがとうございました。

回答No.2

Wendy02

merlionX さん、こんにちは。
ちょっと考えてみました。
以下のプロシージャは単独で動くものですが、この下にある、Selection を、Target[正しくは、With Target.Cells(1) ] にして、イベント(Worksheet_Change())に入れてみたらいかがでしょうか？一応、これは、フォント9～12 の書式スタイルで検証してみました。

ただ、確か、Excelでは、印刷する場合に、調整高が連続した行にあると、セルの中の最後の行が隠れてしまうという現象がありますので、「縦の調整」に、数字を入れて調整してみてください。だいたい、調整高の余分として、そのフォントの高さの1～1.5倍(例:フォント11で、13.5) ぐらいを入れてみてください。

'フォントの高さの定数
Private Const Font12Ht = 14.25
Private Const Font11Ht = 13.5
Private Const Font10Ht = 12
Private Const font9Ht = 11.25
Sub MergeCells_Alignment()
　Dim myStr As String
　Dim myStrLength As Long
　Dim lineHeight As Double
　Dim ea As Variant
　Dim i As Long
　Dim lineStrNum As Long
　Dim wdth As Long
　'幅の調整
　Const WidthAdjustment As Double = 1.5
　'縦の調整
　Const HightAdjustment As Double = 0 'フォント高×1.0～1.5
　'
　With Selection.Cells(1)
　If .MergeCells = False Then Exit Sub
　　For i = 1 To .MergeArea.Count
　　　wdth = wdth + Int(.Offset(, i - 1).ColumnWidth + WidthAdjustment)
　　Next i
　　For Each ea In .MergeArea.Value
　　　myStr = myStr & ea
　　Next
　　myStrLength = LenB(StrConv(myStr, vbFromUnicode))
　　lineStrNum = myStrLength / wdth
　　Select Case .Font.Size
　　　Case 12
　　　　lineHeight = Font12Ht
　　　Case 11
　　　　lineHeight = Font11Ht
　　　Case 10
　　　　lineHeight = Font10Ht
　　　Case 9
　　　　lineHeight = font9Ht
　　End Select
　　.RowHeight = lineHeight * Int(lineStrNum) + HightAdjustment
　　.HorizontalAlignment = xlLeft
　　.VerticalAlignment = xlTop
　　.WrapText = True
　End With
End Sub

お礼

いつもありがとうございます。
かなりの大仕掛けが必要になりますねえ。

勉強させていただきます。
ありがとうございました。