Merged into a corner

Option Explicit

Sub fit_height_merged_cells()
'Erik Van Get
'060612
'use only if "center accross selection" is really not an option

Dim rng As Range
Dim MergeArea As Range
Dim FC As Integer
Dim LC As Integer
Dim FCWidth
Dim TotalWidth As Double
Dim i As Integer

Set rng = Selection
Set MergeArea = rng(1).MergeArea

    If MergeArea.Address <> rng.Address Or rng.Cells.Count = 1 Then
    MsgBox "Please select one MergeArea", 48, "ERROR"
    Exit Sub
    End If

FC = MergeArea.Column
LC = FC + MergeArea.Columns.Count - 1

FCWidth = Columns(FC).ColumnWidth
    
    For i = FC To LC
    TotalWidth = TotalWidth + Columns(i).ColumnWidth
    Next i

Application.ScreenUpdating = False
    rng.UnMerge
    rng(1).ColumnWidth = TotalWidth
    rng(1).EntireRow.AutoFit
    rng.Merge
    Columns(FC).ColumnWidth = FCWidth
Application.ScreenUpdating = True

End Sub