Need VBA Code for dynamic row height

[dsubash]

Hi,

I am looking for a code to have a dynamic row height in my report. I have a database with certain criterias. I also have multiple sheets with filtered data. The report runs from row 9 on each sheet.

I need the default row height to be 12 from row 9 to end of report. I also have fields which has wrap text in them.

So I am basically looking for a code that would allow me to have a default row height of 12 for all the rows and whereever wrap text is available in a row, then the row height should automatically autoadjust to fit the contents.

I have this code which is embedded into the main code, but it is not working properly. Any suggestions on how to correct this code?

Sub AdjustRowHeights(ws As Worksheet, lastRow As Long)
Dim r As Range
Dim cell As Range
Dim hasWrapText As Boolean

ws.Rows("9:" & lastRow).RowHeight = 12

For Each r In ws.Range("C9:E" & lastRow).Rows
hasWrapText = False

For Each cell In r.Cells
If cell.WrapText = True And cell.Value <> "" Then
hasWrapText = True
Exit For ' No need to check other cells in this row
End If
Next cell

If hasWrapText Then
r.EntireRow.AutoFit

End If
Next r
End Sub

This code works fine the autofit incase of availablility of wrap text, but the default row height of 12 is not maintained

Thanks in advance.
Subash D

 

[kvsrinivasamurthy]

Try changing this

If hasWrapText Then
r.EntireRow.AutoFit

End If

as

If hasWrapText Then
r.EntireColumn.AutoFit

End If

 

[vantan]

Hi,

I am looking for a code to have a dynamic row height in my report. I have a database with certain criterias. I also have multiple sheets with filtered data. The report runs from row 9 on each sheet.

I need the default row height to be 12 from row 9 to end of report. I also have fields which has wrap text in them.

So I am basically looking for a code that would allow me to have a default row height of 12 for all the rows and whereever wrap text is available in a row, then the row height should automatically autoadjust to fit the contents.

I have this code which is embedded into the main code, but it is not working properly. Any suggestions on how to correct this code?

Sub AdjustRowHeights(ws As Worksheet, lastRow As Long)
Dim r As Range
Dim cell As Range
Dim hasWrapText As Boolean

ws.Rows("9:" & lastRow).RowHeight = 12

For Each r In ws.Range("C9:E" & lastRow).Rows
hasWrapText = False

For Each cell In r.Cells
If cell.WrapText = True And cell.Value <> "" Then
hasWrapText = True
Exit For ' No need to check other cells in this row
End If
Next cell

If hasWrapText Then
r.EntireRow.AutoFit

End If
Next r
End Sub

This code works fine the autofit incase of availablility of wrap text, but the default row height of 12 is not maintained

Thanks in advance.
Subash D

Try using this code, where MergeCells is the cell address that needs automatic row height adjustment. Add the following code snippet:

If hasWrapText Then
    MergeCellFit cell 
End If

Option Explicit
'Tac gia: anhtuan1066
'Bien soan chinh sua lai: Hoang Trong Nghia
'Nguon  : giaiphapexcel
'---------------------------------------------------------------------------------------
' Chú Thích   :Tien ich chinh lai chieu cao- rong o da mergel
'---------------------------------------------------------------------------------------
Public Sub MergeCellFit(ByVal MergeCells As Range)
    On Error Resume Next
    DoEvents
    Dim Diff As Single
    Dim FirstCell As Range, MergeCellArea As Range
    Dim Col As Long, ColCount As Long, RowCount As Long
    Dim FirstCellWidth As Double, FirstCellHeight As Double, MergeCellWidth As _
            Double
    If MergeCells.Count = 1 Then
        Set MergeCellArea = MergeCells.MergeArea
    Else
        Set MergeCellArea = MergeCells
    End If
    With MergeCellArea
        ColCount = .Columns.Count   'Tong so cot
        RowCount = .Rows.Count  'Tong so dong
        .VerticalAlignment = xlTop  'Canh tren
        .WrapText = True    'Xuong dong
        ' Neu so dong =1 va so cot = 1 thi
        If RowCount = 1 And ColCount = 1 Then
            .EntireRow.AutoFit
            GoTo ExitSub
        End If
        'Gán ô cân fix
        Set FirstCell = .Cells(1, 1)
        'Chieu rong o dau tien
        FirstCellWidth = FirstCell.ColumnWidth
        Diff = 0.75
        'Tinh tong chieu rong cua o duoc merge
        For Col = 1 To ColCount
            MergeCellWidth = MergeCellWidth + .Cells(1, Col).ColumnWidth + Diff
        Next
        'Bo merge
        .MergeCells = False
        'Gan chieu rong o dau = Tong chieu rong
        FirstCell.ColumnWidth = MergeCellWidth - Diff
        'Fix chieu cao dong
        .EntireRow.AutoFit
        'Gan chieu cao dong
        FirstCellHeight = FirstCell.RowHeight + 1
        'Merge lai
        .MergeCells = True
        'Gan lai chieu cao o dau lai ve so ban dau
        FirstCell.ColumnWidth = FirstCellWidth
        'Gan chieu cao dong lai
        FirstCellHeight = FirstCellHeight / RowCount
        .RowHeight = FirstCellHeight
    End With
ExitSub:
    On Error GoTo 0
End Sub