Autofit Merged Cells with VBA

Excel can make cells autofit to a cell with a little help from VBA.  This year (2013) I have been following the blog post on Contextures about auto fitting cells.  I became interested as a mate of mine sent me a file and asked me to make multiple non continuous ranges autofit automatically.  The blog post was a god send in that it had all of the code to auto fit a cell. So I went ahead and pushed the code so it incorporated multiple cells and multiple ranges.  After I finished I wanted to share the data in the blog so I posed the code and a stream of questions flooded in.  I have done my best to answer the questions and put a link on the blog to a file which addresses most of the questions.  A file is often a good starting point as it shows people who are not day to day programmers how the basic concept works.  

Below is the link to the blog post on Contextures.

http://blog.contextures.com/archives/2012/06/07/autofit-merged-cell-row-height/

The following procedure will fit the cells in a static range.  The cells within the array variant (ar) are the ones which need to be changed to suit your model.

Option Explicit
Sub FixMerged() 'Excel VBA to autofit merged cells
Dim mw As Single
Dim cM As Range
Dim rng As Range
Dim cw As Double
Dim rwht As Double
Dim ar As Variant
Dim i As Integer

Application.ScreenUpdating=False
'Cell Ranges below, change to suit.
ar = Array("C10", "C12", "C14", "C16", "C18", "C20")

For i=0 To UBound(ar)
On Error Resume Next
Set rng=Range(Range(ar(i)).MergeArea.Address)
rng.MergeCells=False
cw=rng.Cells(1).ColumnWidth
mw=0
For Each cM In rng
cM.WrapText=True
mw=cM.ColumnWidth + mw
Next
mw=mw + rng.Cells.Count * 0.66
rng.Cells(1).ColumnWidth=mw
rng.EntireRow.AutoFit
rwht=rng.RowHeight
rng.Cells(1).ColumnWidth=cw
rng.MergeCells=True
rng.RowHeight=rwht
Next i
Application.ScreenUpdating=True
End Sub

Another possibility is that your merged cells are sequential.  The following is an example of merged cells in column C being fitted to the cell based on the content in the cell.

Sub FixMergedSequential() 'Excel VBA to autofit sequential merged cells
Dim mw As Single
Dim cM As Range
Dim rng As Range
Dim cw As Double
Dim rwht As Double
Dim ar As Variant
Dim i As Integer

Application.ScreenUpdating=False

For i=10 To Range("C" & Rows.Count).End(xlUp).Row
On Error Resume Next
Set rng=Range(Range("C" & i).MergeArea.Address)
rng.MergeCells=False
cw=rng.Cells(1).ColumnWidth mw=0
For Each cM In rng
cM.WrapText=True
mw=cM.ColumnWidth + mw
Next
mw=mw + rng.Cells.Count * 0.66
rng.Cells(1).ColumnWidth=mw
rng.EntireRow.AutoFit r
wht= rng.RowHeight
rng.Cells(1).ColumnWidth= cw
rng.MergeCells=True
rng.RowHeight=rwht Next i
Application.ScreenUpdating=True
End Sub

Attached is the file within the file is an additional procedure, an onchange event which will change the cells automatically when ever typing is complete.

This technique is forever evolving and from Debra's site a dragon entered the fray. Juan Sanchez dropped this little gem into the mixing pot. Quite simply, wonderful.

Option Explicit'New take on the above improves the autofit merged cells technique.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Vhight As Single
If Target.WrapText=True Then
With Target
.Select
.RowHeight=1
.WrapText=True
.UnMerge
.EntireRow.AutoFit
Selection.Merge
Vhight=.Width * .Height / Selection.Width
If Vhight < 16 Then Vhight=16
.RowHeight=Vhight
.VerticalAlignment=xlCenter
End With
End If
End Sub

'#Boom

I am rarely this impressed.  The above improves the technique and I am proud to add this to the discussion on this page. Well done Juan.  I have added this VBA coding to the Excel file.

FIT ROW HEIGHT TO LARGEST TEXT

For quite some time I have been wrestling with the concept of multiple merged cells in the same row. I have been unable to figure out how to merge the cells to the cell containing the most text. I had a moment of clarity while working with a friend of mine. The outcome is the following merged cells code which will consider the cell containing the most text and adjust the whole line according to that cell.

The attached file contains the merged cells procedure. This procedure is the Red tab at the end.

Option Explicit 'Excel VBA to fit row height to the largest amount of text in that row.
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 = Range("C10:O" & Range("C" & Rows.Count).End(xlUp).Row)

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
'store the max row height for this row
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