Excel Tutorial: Automatically Wrap contents in merged and unmerged cells in excel using macro

You would have noticed that excel does not automatically wrap cell conents when it is merged or sometimes when the height is fixed in an unmerged cell, it does not wrap. Remember: Excel does not have the functionality to wrap merged cell contents. To address this issue we are going to use the below macro.

Step 1: If you want all the sheets in the entire workbook to get affected
a. Open Tools > Macro > Visual Basic Editor
b. On the left hand side you can see the Project Explorer Window(If you are not able to see, just enable it by going to View > Project Explorer
c. Then you can see sheets available in the workbook in the project explorer window, Just Double Click the sheet named "ThisWorkbook"
d. Copy and paste the below code:

Code in "ThisWorkbook"

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
      Dim cel As Range
      If Not Target.Cells(1, 1).MergeCells Then
            AutoFitUnMergedCells Target
            Exit Sub
      End If

      Set cel = ActiveCell
      On Error Resume Next
      Application.EnableEvents = False
      AutoFitMergedCells Target
      cel.Select 'Without this statement, cursor ends up in column IV
      Application.EnableEvents = True
      On Error GoTo 0
End Sub

Step 2: If you want only a particular sheet to get affected
a. Double Click any sheet in the project explorer window and copy and paste the below code into it

Code in Module

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range
If Not Target.Cells(1, 1).MergeCells Then
Target.EntireRow.AutoFit
Exit Sub
End If

Set cel = ActiveCell
On Error Resume Next
Application.EnableEvents = False
AutoFitMergedCells Target
cel.Activate            'Without this statement, cursor ends up in column IV
Application.EnableEvents = True
On Error GoTo 0
End Sub

'This sub may go either in the same module sheet as one of the previous subs, or in a regular module sheet
Sub AutoFitMergedCells(Target As Range)
'AutoFits a merged cell range, even though it is technically impossible
Dim MergedWidth As Double, NewHeight As Double, ReqdHeight As Double
Dim cel As Range, celTemp As Range, col As Range, colCopy As Range, rg As Range, rw As Range
Dim Mergers As New Collection
Dim i As Long, nMerge As Long, nRow As Long
Set rg = Target.Cells(1, 1)

If Not rg.MergeCells Then Exit Sub
Application.ScreenUpdating = False

'Identify all the merged ranges in this row
nRow = rg.Row
With Target.Parent         'The worksheet containing the range Target
      For i = 1 To 256
            If .Cells(nRow, i).MergeCells And .Cells(nRow, i).WrapText Then
                  nMerge = nMerge + 1
                  Mergers.Add Item:=.Cells(nRow, i).MergeArea
                  i = i + .Cells(nRow, i).MergeArea.Columns.Count - 1
            End If
      Next
      Set colCopy = .Columns(256) '.Insert      'Insert an empty column
      Set celTemp = colCopy.Cells(nRow, 1)
End With

For i = 1 To nMerge    'Loop through all the merged areas on this row
      Set rg = Mergers(i)
      With rg
                  MergedWidth = 0
                  Set cel = .Cells(1, 1)
                  For Each col In .Columns
                        MergedWidth = col.Width + MergedWidth                'Measured in points
                  Next col

                  .MergeCells = False
                           'points=5.25*characters + 3.75
                  colCopy.ColumnWidth = 0.1905 * MergedWidth - 0.7139       'Convert from points to "characters"
                  cel.Copy
                  celTemp.PasteSpecial xlPasteValues
                  celTemp.PasteSpecial xlPasteFormats
                  .MergeCells = True

                  celTemp.EntireRow.AutoFit

                  'For some reason, celTemp.EntireRow.Height changes when .MergeCells=True
                  If celTemp.EntireRow.Height > ReqdHeight Then ReqdHeight = celTemp.EntireRow.Height
      End With
Next
colCopy.ClearContents
i = Target.Parent.UsedRange.Rows.Count
For Each rw In Target.MergeArea.Rows
      rw.RowHeight = Application.Max(ReqdHeight / Target.MergeArea.Rows.Count + 0.49, 15)      'Round row height up to 0.5 points, minimum of 12.75 points
Next

If ReqdHeight >= 409.5 Then MsgBox "Warning! Text is truncated because maximum merged cell height is 409.5 points"
Application.ScreenUpdating = True
End Sub

Sub AutoFitUnMergedCells(Target As Range)
Dim rw As Range
For Each rw In Target.Rows
      tempheight = rw.EntireRow.RowHeight
      rw.EntireRow.AutoFit

      If rw.Cells.Height > tempheight Then
            rw.EntireRow.RowHeight = rw.Cells.Height
      Else
            rw.EntireRow.RowHeight = tempheight
      End If
Next
End Sub

Note: When the sheet is protected, you need to add a small function that will first unprotect the sheet another function that will protect the sheet and place it in the worksheet_change function wherever required.

You can search for the tutorial at expertsforge which demonstrates how to unprotect/protect the sheet using macro.