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!