Sub RowHeightFiting2()
' Объединённая ячейка должна быть активной!!!
Application.ScreenUpdating = False
Dim MyRanAdr As String
Dim MergeAreaTotalHeight, NewRH
Dim MergeAreaFirstCellColWidth, MergeAreaFirstCellColHeight
MyRanAdr = ActiveCell.MergeArea.Address 'адрес области с объединённой ячейкой
MergeAreaTotalHeight = Range(MyRanAdr).Height ' высота всей объединённой ячейки в ед. пт
MergeAreaFirstCellColWidth = Range(MyRanAdr).Cells( 1 ,  1 ).EntireColumn.ColumnWidth ' ширина первого столбца в объединённой ячейке
MergeAreaFirstCellColHeight = Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.RowHeight ' высота первой строки в объединённой ячейке
Range(MyRanAdr).Cells( 1 ,  1 ).ColumnWidth = (Range(MyRanAdr).Width -  3 . 75 ) /  4 . 5  'установка ширины первого столбца объед. ячейки равной общей ширине объед. ячейки  '''БЕЗ ПОДГОНКИ!!!
Range(MyRanAdr).WrapText = True
Range(MyRanAdr).MergeCells = False
Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.AutoFit
NewRH = Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.RowHeight
Range(MyRanAdr).MergeCells = True
Range(MyRanAdr).Cells( 1 ,  1 ).EntireColumn.ColumnWidth = MergeAreaFirstCellColWidth
Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.RowHeight = NewRH - (MergeAreaTotalHeight - MergeAreaFirstCellColHeight) ' для 1-й строки в объед.ячейке
'Range(MyRanAdr).EntireRow.RowHeight = NewRH / Range(MyRanAdr).Rows.Count 'вместо предыдущей стоки кода для равной высоты всех строк в объед.ячейке
Application.ScreenUpdating = True
End Sub 

Sub MiddEdgeWidth() 
' Определение ширины (в пт) единицы символа ("середины") и краёв ("боковушек") для текущего стиля Normal 
' Для этого определения используется самая последняя ячейка, но можно использовать любую, в данном случае не важно 
Dim MyNormalMiddleWidth, MyNormalEdgeWidth 
Dim c1, c2, w1, w2 'временные переменные ширин столбцов в симв и пт 
Dim MyTempCell As Range 
Dim OldColWidth 'ширина временной ячейки до манипуляций (чтобы потом вернуть обратно, на всякий случай) 
Set MyTempCell = Cells( 65536 ,  256 ) 
OldColWidth = MyTempCell.ColumnWidth 
c1 =  10  ' ширину в симв можно установить любую, но точно не менее 1 (где нельзя реально определить нужные нам данные), 
c2 =  15  ' и лучше более 3 и целочисленные (для уменьшения влияния ошибки округления..... впрочем, в коде эта возможная ошибка учитывается) 

' Установка ширины ячейки в симв и получения получившихся реальных ширин в симв и пт 
MyTempCell.ColumnWidth = c1 
c1 = MyTempCell.ColumnWidth 
w1 = MyTempCell.Width 
MyTempCell.ColumnWidth = c2 
c2 = MyTempCell.ColumnWidth 
w2 = MyTempCell.Width 

' Вычисление ширин "середины" и "боковушек" (пришлось вспомнить решение системы из 2-х простых уравнений за 5-й класс школы) 
MyNormalMiddleWidth = Format((w2 - w1) / (c2 - c1), "#0.00") ' тут Format - для округления возможной ошибки вычисления 
MyNormalEdgeWidth = Format((c2 * w1 - c1 * w2) / (c2 - c1), "#0.00") 

' Возврат в исходное состояние 
MyTempCell.ColumnWidth = OldColWidth 

'Вывод сообщения о текущем стиле Normal и его ширинах 
MsgBox "Шрифт текущего стиля   -    " & Application.StandardFont & _ 
Chr( 10 ) & "Его размер                      -    " & Application.StandardFontSize & _ 
Chr( 10 ) & Chr( 10 ) & "Ширина ""середины""      -      " & MyNormalMiddleWidth & _ 
Chr( 10 ) & "Ширина ""краёв""             -      " & MyNormalEdgeWidth 
End Sub

Sub RowHeightFiting3() 
' Объединённая ячейка должна быть активной!!! 
' Если требуется подобрать высоту для неактивной ячейки, то нужно переменной MyRanAdr присвоить ПОЛНЫЙ адрес области объединённой ячейки  '(Напр, MyRanAdr = "D4:G7" вместо строки MyRanAdr = ActiveCell.MergeArea.Address) 
Application.ScreenUpdating = False 

Dim MyNormalMiddleWidth, MyNormalEdgeWidth 
Dim c1, c2, w1, w2 'временные переменные ширин столбцов в симв и пт 
Dim MyTempCell As Range 
Dim OldColWidth 
Set MyTempCell = Cells( 65536 ,  256 ) 
OldColWidth = MyTempCell.ColumnWidth 
c1 =  10  ' ширину в симв можно установить любую, но точно не менее 1 (где нельзя реально определить нужные нам данные), 
c2 =  15  ' и лучше более 3 и целочисленные (для уменьшения влияния ошибки округления) 
MyTempCell.ColumnWidth = c1 
c1 = MyTempCell.ColumnWidth 
w1 = MyTempCell.Width 
MyTempCell.ColumnWidth = c2 
c2 = MyTempCell.ColumnWidth 
w2 = MyTempCell.Width 
MyNormalMiddleWidth = Format((w2 - w1) / (c2 - c1), "#0.00") 
MyNormalEdgeWidth = Format((c2 * w1 - c1 * w2) / (c2 - c1), "#0.00") 
MyTempCell.ColumnWidth = OldColWidth 
Dim MyRanAdr As String 
Dim MergeAreaTotalHeight, NewRH 
Dim MergeAreaFirstCellColWidth, MergeAreaFirstCellColHeight 
MyRanAdr = ActiveCell.MergeArea.Address 'адрес области с объединённой ячейкой 
MergeAreaTotalHeight = Range(MyRanAdr).Height ' высота всей объединённой ячейки в ед. пт 
MergeAreaFirstCellColWidth = Range(MyRanAdr).Cells( 1 ,  1 ).EntireColumn.ColumnWidth ' ширина первого столбца в объединённой ячейке 
MergeAreaFirstCellColHeight = Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.RowHeight ' высота первой строки в объединённой ячейке 
Range(MyRanAdr).Cells( 1 ,  1 ).ColumnWidth = (Range(MyRanAdr).Width - MyNormalEdgeWidth) / MyNormalMiddleWidth 'установка ширины первого столбца объед. ячейки равной общей ширине объед. ячейки  '''БЕЗ ПОДГОНКИ!!! 
Range(MyRanAdr).WrapText = True 
Range(MyRanAdr).MergeCells = False 
Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.AutoFit 
NewRH = Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.RowHeight 
Range(MyRanAdr).MergeCells = True 
Range(MyRanAdr).Cells( 1 ,  1 ).EntireColumn.ColumnWidth = MergeAreaFirstCellColWidth 
Range(MyRanAdr).Cells( 1 ,  1 ).EntireRow.RowHeight = NewRH - (MergeAreaTotalHeight - MergeAreaFirstCellColHeight) ' для 1-й строки в объед.ячейке 
'Range(MyRanAdr).EntireRow.RowHeight = NewRH / Range(MyRanAdr).Rows.Count 'для равной высоты всех строк в объед.ячейке 
Application.ScreenUpdating = True 
End Sub 

Вроде, понятно объяснил....