VBA Code To Autofit The Row Height Of Merged Cells

[David Michael]

Hi, I found the code below and it works pretty well, but it limits how much content is displayed. For example, I have 1 sheet where the combined width of the merged columns is 1,146 pixels and so, if a ton of content is entered, the # of rows that are displayed is limited to 6. On another sheet where the combined width is 815 pixels, the limit is 8 rows. Does anybody know of a way to address this? On the sheet where the combined width is 1,146 pixels, I need to display at least 10 rows worth of content.

Thank you!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim MergeWidth As Single
Dim cM As Range
Dim AutoFitRng As Range
Dim CWidth As Double
Dim NewRowHt As Double
Dim str01 As String
str01 = "OrderNote"

  If Not Intersect(Target, Range(str01)) Is Nothing Then
    Application.ScreenUpdating = False
    On Error Resume Next
    Set AutoFitRng = Range(Range(str01).MergeArea.Address)

    With AutoFitRng
      .MergeCells = False
      CWidth = .Cells(1).ColumnWidth
      MergeWidth = 0
      For Each cM In AutoFitRng
          cM.WrapText = True
          MergeWidth = cM.ColumnWidth + MergeWidth
      Next
      'small adjustment to temporary width
      MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66
      .Cells(1).ColumnWidth = MergeWidth
      .EntireRow.AutoFit
      NewRowHt = .RowHeight
      .Cells(1).ColumnWidth = CWidth
      .MergeCells = True
      .RowHeight = NewRowHt
    End With
    Application.ScreenUpdating = True
  End If

End Sub