縦方向の結合にも対応させてみたが思ったより大げさになってしまった。
Option Explicit '結合したセルの高さを自動調節する ' ' 処理の概要 ' - 新しいブックを作成し、書式、標準のフォントとそのサイズを選択したセル範囲からコピー ' (標準のフォントの大きさによって長さ当たりのピクセル数が変わってくるので標準のフォントを揃えること重要) ' - 結合したセル範囲の一覧を作成しDictionaryObjectに保存する ' - 結合したセル範囲を一つずつ取り出しテスト用のセルにコピーする ' - テスト用のセルを結合後の幅に揃えたうえでAutoFitする。 ' - テスト用セルの高さと現在の高さを比べて高いほうに高さを設定する。 Sub AutofitMergedCells() AutofitMergedCells_ Selection End Sub Private Sub AutofitMergedCells_(Target As Range) '自動調節したいセル範囲、ブック等を変数に格納 =>TargetBook Dim TargetBook As Workbook Set TargetBook = Target.Worksheet.Parent Dim NormalFontName As String NormalFontName = TargetBook.Styles("Normal").Font.Name ' 後で取得するとなぜかMSゴシックが返ってくるので最初に取得しておく Dim NormalFontSize As Double NormalFontSize = TargetBook.Styles("Normal").Font.Size '高さを調べるためのテスト用ブックの用意 =>TestBook ' Dim TestBook As Workbook Set TestBook = Workbooks.Add Dim TestSheet As Worksheet Set TestSheet = TestBook.Worksheets(1) Dim TestCell As Range Set TestCell = TestSheet.Cells(1, 1) 'テストブックのNormalスタイル TestBook.Styles("Normal").Font.Name = NormalFontName TestBook.Styles("Normal").Font.ThemeFont = xlThemeFontNone TestBook.Styles("Normal").Font.Size = NormalFontSize Dim tmpRow As Range For Each tmpRow In Target.Rows tmpRow.AutoFit Next Dim Areas As New Scripting.Dictionary Set Areas = MergedAreas(Target) Dim k For Each k In Areas.Keys Dim Area As Range Set Area = Areas(k) Dim RemainHeight As Double RemainHeight = HeightToFit(Area, TestCell) Dim RowHeight As Double Dim Row As Range Dim Index As Long Index = 1 While 0 < RemainHeight RowHeight = RemainHeight / (Area.Rows.Count - Index + 1) Set Row = Area.Rows(Index) If Row.RowHeight < RowHeight Then Row.RowHeight = RowHeight End If RemainHeight = RemainHeight - Row.RowHeight Index = Index + 1 Wend Continue_: Next TestBook.Close False End Sub '結合したセルをAutoFitした場合の高さ Private Function HeightToFit(Area As Range, TestCell As Range) Dim Row As String Dim MergedAreas As New Scripting.Dictionary Dim c As Range For Each c In Area.Cells If Not MergedAreas.Exists(c.MergeArea.Address) Then MergedAreas.Add c.MergeArea.Address, c.MergeArea End If Next Dim MergedCells HeightToFit = 0 For Each MergedCells In MergedAreas.Items Dim MergedWidth As Double MergedWidth = 0 Dim Col As Range For Each Col In MergedCells.Columns MergedWidth = MergedWidth + Col.ColumnWidth Next MergedWidth = MergedWidth MergedCells.Copy TestCell.Worksheet.Paste TestCell TestCell.MergeCells = False TestCell.ColumnWidth = MergedWidth TestCell.Value = MergedCells.Value TestCell.EntireRow.AutoFit HeightToFit = IIf(HeightToFit < TestCell.RowHeight, TestCell.RowHeight, HeightToFit) Next End Function Private Function MergedAreas(Range As Range) As Scripting.Dictionary Dim Dict As New Dictionary Dim Cell As Range For Each Cell In Range If Cell.MergeCells And Not Dict.Exists(Cell.MergeArea.Address) Then Dict.Add Cell.MergeArea.Address, Cell.MergeArea End If Next Set MergedAreas = Dict End Function