'''
Option Explicit
'========================================
' 指定ファイルの指定シートを直接修正：
' BA～BKにある「結合セル」だけを対象に
' 見切れていればその行の高さを現在の2倍にする
'========================================
Public Sub FixRowsHeight_ByMergedCells_BAtoBK()
'==== 設定ここだけ変更 ====
Const TARGET_FILE As String = "C:\work\sample.xlsx"
Const TARGET_SHEET As String = "Sheet1"
Const COL_START As String = "BA"
Const COL_END As String = "BK"
Const EPS As Double = 0.8 ' 誤差吸収（全行が引っかかる場合は 1.5 などに上げてOK）
'========================
Dim wb As Workbook
Dim ws As Worksheet
Dim tmpWs As Worksheet
Dim tmpCell As Range
Dim leftCol As Long, rightCol As Long
Dim ur As Range
Dim rowRange As Range
Dim beforeH As Double, needH As Double
Dim area As Range
Dim checkRange As Range
On Error GoTo EH
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'--- 開く ---
Set wb = Workbooks.Open(TARGET_FILE)
Set ws = wb.Worksheets(TARGET_SHEET)
leftCol = ws.Columns(COL_START).Column
rightCol = ws.Columns(COL_END).Column
Set ur = ws.UsedRange
If ur Is Nothing Then GoTo CLEANUP
'--- 計測用一時シート ---
Set tmpWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
tmpWs.Name = CreateTempSheetName(wb, "zz_tmp_autofit_")
tmpWs.Visible = xlSheetVeryHidden
Set tmpCell = tmpWs.Range("A1")
'--- 行ごとにチェック ---
For Each rowRange In ur.Rows
beforeH = rowRange.RowHeight
' BA～BK の範囲（その行）だけ見る
Set checkRange = ws.Range(ws.Cells(rowRange.Row, leftCol), ws.Cells(rowRange.Row, rightCol))
' MergeAreasは単セルも返すので、結合セルだけに絞る
For Each area In checkRange.MergeAreas
If area.MergeCells And area.Count > 1 Then
' ※要件が「BA～BKの結合セルを対象」なので
' 結合範囲が BA～BK に完全に収まるものだけ判定
If area.Column >= leftCol And (area.Column + area.Columns.Count - 1) <= rightCol Then
needH = RequiredHeightForMergedArea(area, tmpCell, beforeH)
If needH > beforeH + EPS Then
ws.Rows(rowRange.Row).RowHeight = beforeH * 2
Exit For ' この行は確定（次の行へ）
End If
End If
End If
Next area
Next rowRange
'--- 一時シート削除 ---
tmpWs.Visible = xlSheetVisible
tmpWs.Delete
CLEANUP:
'--- 保存して閉じる ---
wb.Save
wb.Close SaveChanges:=False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "完了：BA～BKの結合セルを判定し、見切れ行だけ高さを2倍にして保存しました。", vbInformation
Exit Sub
EH:
' エラー時も設定を戻す
On Error Resume Next
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "エラー: " & Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub
'========================================
' 結合セル(MergeArea)の必要高さを
' 非結合の一時セルで測って返す
'========================================
Private Function RequiredHeightForMergedArea(ByVal area As Range, ByVal tmpCell As Range, ByVal baseHeight As Double) As Double
Dim tl As Range
Dim widthSum As Double
Dim colR As Range
Set tl = area.Cells(1, 1)
' 空なら判定不要
If Len(CStr(tl.Value)) = 0 Then
RequiredHeightForMergedArea = baseHeight
Exit Function
End If
' 折り返しOFFかつ改行なし → 縦方向見切れになりにくいので判定対象外
'（横に切れているだけなら行高を上げても解決しない）
If (tl.WrapText = False) And (InStr(CStr(tl.Value), vbLf) = 0) And (InStr(CStr(tl.Value), vbCr) = 0) Then
RequiredHeightForMergedArea = baseHeight
Exit Function
End If
' 結合セルの幅（列幅合計）
widthSum = 0
For Each colR In area.Columns
widthSum = widthSum + colR.ColumnWidth
Next colR
With tmpCell
.Clear
' 値と見た目（主要分だけ）をコピー
.Value = tl.Value
.NumberFormat = tl.NumberFormat
.Font.Name = tl.Font.Name
.Font.Size = tl.Font.Size
.Font.Bold = tl.Font.Bold
.Font.Italic = tl.Font.Italic
.WrapText = tl.WrapText
.HorizontalAlignment = tl.HorizontalAlignment
.VerticalAlignment = tl.VerticalAlignment
' 幅と高さをセットしてAutoFitで計測
.ColumnWidth = widthSum
.RowHeight = baseHeight
.EntireRow.AutoFit
RequiredHeightForMergedArea = .RowHeight
' 後始末
.Clear
.RowHeight = baseHeight
End With
End Function
'========================================
' 一時シート名（被り回避）
'========================================
Private Function CreateTempSheetName(ByVal wb As Workbook, ByVal prefix As String) As String
Dim i As Long, nm As String
For i = 1 To 9999
nm = prefix & Format$(i, "0000")
If Not SheetExists(wb, nm) Then
CreateTempSheetName = nm
Exit Function
End If
Next i
CreateTempSheetName = prefix & "9999"
End Function
Private Function SheetExists(ByVal wb As Workbook, ByVal sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(sheetName)
SheetExists = Not ws Is Nothing
On Error GoTo 0
End Function