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 

[Admin]

Hi

Welcome to board !!

Try something like this.

Option Explicit

Private Function NewRowHeight(ByVal MyPixels As Long) As Long
    
    Select Case MyPixels
        Case 1 To 100
            NewRowHeight = 15
        Case 101 To 250
            NewRowHeight = 35
        'more cases
        Case 1100 To 1200
            NewRowHeight = 90
    End Select
    
End Function

[David Michael]

Hi, thank you for the reply, but I unfortunately have to ask a stupid question: where should that new code go? I'm obviously a VBA novice so I tried inserting it a few different ways (inside the exisiting code on the worksheet, as a module, as a class module), but either got a compile error or didn't see any change from previous results.

Thanks again!

[Admin]

Hi

The code goes in the same sheet module.

Option Explicit

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
      
      '//get the row height based on the given pixel
      NewRowHt = NewRowHeight(MergeWidth) 'here MergeWidth is the pixels
      
      .Cells(1).ColumnWidth = CWidth
      .MergeCells = True
      .RowHeight = NewRowHt
    End With
    Application.ScreenUpdating = True
  End If

End Sub


Private Function NewRowHeight(ByVal MyPixels As Long) As Long
    
    Select Case MyPixels
        Case 1 To 100
            NewRowHeight = 15 '<< adjust the row height here
        Case 101 To 250
            NewRowHeight = 35 '<< adjust the row height here
        'more cases
        Case 1100 To 1200
            NewRowHeight = 90 '<< adjust the row height here
    End Select
    
End Function

[David Michael]

Hi, I cleared the code from the worksheet in question and pasted in what you provided. I can see that it's doing something, but it doesn't seem to be operating as intended. The row height was set to 15 (20 pixels) regardless of how much content I entered. I did play with changing "15" to another value and can see the effect, but it continues to set the row height to the new value every time.

I might just be misunderstanding. I can see that the code assigns different row heights to "Case 1 To 100", "Case 101 To 250" and "Case 1100 To 1200", but I guess I don't understand what that's referring to. It doesn't seem to refer to the amount of content entered (as I got the same row height regardless of whether I entered a little or a ton) or the combined width of the merged columns (as I played with those and saw no change).

Thanks again for your help!

[Excel Fox]

David, here's another suggestion. Replace your entire code with this.

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

    If Not Intersect(Target, Range(str01)) Is Nothing Then
        Application.ScreenUpdating = False
        Set AutoFitRng = Range(str01).MergeArea
        For Each cM In AutoFitRng.Cells
            MergeWidth = cM.ColumnWidth + MergeWidth
        Next cM
        
        With Worksheets.Add
            .Columns(1).ColumnWidth = MergeWidth
            With .Cells(1)
                .Value = AutoFitRng.Cells(1).Value
                .WrapText = True
                .EntireRow.AutoFit
            End With
            NewRowHt = .Rows(1).Height
            Application.DisplayAlerts = False
            .Delete
            Application.DisplayAlerts = False
        End With
        With AutoFitRng
            .WrapText = True
            .RowHeight = NewRowHt
        End With
        Application.ScreenUpdating = True
    End If

End Sub

[David Michael]

Hi, I'm sorry to report that this new code just gets me back to the same place as the original code, i.e. it works in terms of autosizing the row height, but limits that row height to 6-8 rows worth of content, depending on the combined width of the merged cells.

I'm starting to think that this might not be possible and so am considering a workaround: in addition to using this code, which will cover any use of the worksheet where the data entered in the field is 6-8 rows or less, I could put a button above the field with something like "Enlarge" written on it, and assign a macro that expands the row height to allow for 10 rows of content.

Everything I just described I can do, but the macro would work better if, rather than just changing the row height to 170 pixels (10 rows), it could identify the current row height and add 17 pixels (1 row). In this way, each press of the "Enlarge" button would expand the row height to allow 1 more row's worth of content to be displayed. Is it possible to build a macro that does that? If it helps, the sheet I'm working on is called "Loss Evaluation", the field is named "OrderNote" and the cell range is A18:L18.

Thank you!