Auto Fit Row Height Of Merged Cells

[jann6628]

Hi.

Is there any way i can make excel autofit row height of merge cells?

 

[MARK858]

Did you check that wrap text is still checked (a tick not a filled checkbox)?

 

[jann6628]

Oh your right.! But how do i get it to run all the time? so I don't have to run i manually every time?

 

[MARK858]

Oh your right.! But how do i get it to run all the time? so I don't have to run i manually every time?

Just put in a line to force the wrap text

Rows("2:2").WrapText = True

Adjust the code above and the main code to the row that you want (50 or the last row or whatever).

 

[jann6628]

the problem is not that it is not wrapped, but that it doesn't adjust the row height when i change the text, unless I press "Run" i VBA.

 

[MARK858]

You didn't ask for it to run when the cell is changed originally, that requires worksheet_change code which I don't have time to write now.
I will look at it later.

 

[MARK858]

Keeping it simple.
Code below in a Regular module

Sub MergedAreaRowAutofit()
Dim j As Long
Dim n As Long
Dim i As Long
Dim MW As Double 'merge width
Dim RH As Double 'row height
Dim MaxRH As Double
Dim rngMArea As Range
Dim rng As Range

Const SpareCol  As Long = 26
Set rng = Cells(Rows.Count, "B").End(xlUp)
Rows(rng.Row).WrapText = True

With rng
  For j = 1 To .Rows.Count
     'if the row is not hidden
    If Not .Parent.Rows(.Cells(j, 1).Row) _
      .Hidden Then
       'if the cells have data
      If Application.WorksheetFunction _
        .CountA(.Rows(j)) Then
        MaxRH = 0
        For n = .Columns.Count To 1 Step -1
          If Len(.Cells(j, n).Value) Then
             'mergecells
            If .Cells(j, n).MergeCells Then
              Set rngMArea = _
                .Cells(j, n).MergeArea
              With rngMArea
                MW = 0
                If .WrapText Then
                   'get the total width
                  For i = 1 To .Cells.Count
                    MW = MW + _
                      .Columns(i).ColumnWidth
                  Next
                  MW = MW + .Cells.Count * 0.66
                   'use the spare column
                   'and put the value,
                   'make autofit,
                   'get the row height
                  With .Parent.Cells(.Row, SpareCol)
                    .Value = rngMArea.Value
                    .ColumnWidth = MW
                    .WrapText = True
                    .EntireRow.AutoFit
                    RH = .RowHeight
                    MaxRH = Application.Max(RH, MaxRH)
                    .Value = vbNullString
                    .WrapText = False
                    .ColumnWidth = 8.43
                  End With
                  .RowHeight = MaxRH
                End If
              End With
            ElseIf .Cells(j, n).WrapText Then
              RH = .Cells(j, n).RowHeight
              .Cells(j, n).EntireRow.AutoFit
              If .Cells(j, n).RowHeight < RH Then _
                .Cells(j, n).RowHeight = RH
            End If
          End If
        Next
      End If
    End If
  Next
  .Parent.Parent.Worksheets(.Parent.Name).UsedRange
End With
End Sub

Code below in the Worksheet's module

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Cells(Rows.Count, "B").End(xlUp)) Is Nothing And Target.CountLarge = 1 Then
        Application.EnableEvents = False
        MergedAreaRowAutofit
        Application.EnableEvents = True
    End If
End Sub

 

[jann6628]

Thanks everybody.!
I finally got the solution:

If Not Intersect(Target, Range("B50")) Is Nothing Then

Dim CurrentRowHeight As Single
Dim MergedCellRgWidth As Single
Dim ActiveCellWidth As Single
Dim PossNewRowHeight As Single
Dim CurrCell As Range

    Range("B50").Select

    If ActiveCell.MergeCells Then
      With ActiveCell.MergeArea
            If .Rows.Count = 1 And .WrapText = True Then
                Application.ScreenUpdating = False
                CurrentRowHeight = .RowHeight
                ActiveCellWidth = ActiveCell.ColumnWidth
               
                For Each CurrCell In Selection
                    MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
                Next
               
                .MergeCells = False
                .Cells(1).ColumnWidth = MergedCellRgWidth
                .EntireRow.Autofit
                PossNewRowHeight = .RowHeight
                .Cells(1).ColumnWidth = ActiveCellWidth
                .MergeCells = True
                .RowHeight = PossNewRowHeight
            End If
        End With
    End If
End If
    Application.ScreenUpdating = True

 

[toowaki]

I made excel add-in. You can use it to automatically adjust the height of cells, including merged cells.

[AutoFitRowEx - Github]
Releases · toowaki/AutoFitRowEx