Auto adjust row height (merged cells)

[Noz2k]

Hi I'm currently having a bit of trouble with wrap text not working for merged cells.

Was wondering if there was a way in which to create a macro that works on the worksheet activate function to automatically adjust the height of the merged cells to fit the text?

I've tried a couple of ways which I have found through searching but can't get them to work.

I'm using Excel 2010 and the range I want to do it for is ("A1:I255") and the worksheet is named "WeeklySummary"

Thanks

 

[Noz2k]

Right well I have it almost working now, discovered where I was going wrong (had another macro running which protects the sheet)

here is the code

Private Sub Worksheet_Activate()
 
Sheets("WeeklySummary").Unprotect "abc123"
Set Target = Range("A1:I255")
 
If Intersect(ActiveCell, Target) Is Nothing Then Exit Sub
 
Dim snCurrRowH As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim stCell As String
 
With ActiveCell.MergeArea
    If .Rows.Count = 1 And .WrapText = True Then
        Application.ScreenUpdating = False
        snCurrRowH = .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 = IIf(snCurrRowH > PossNewRowHeight, snCurrRowH, PossNewRowHeight)
      End If
End With
 
End Sub

The problem I have though, is that in a couple of instances it isn't working, and I can't work out why? Any idea what could be preventing some cells from working and not others?

 

[Noz2k]

I think it may be that it is only working for the final instance where the height is too small to fit all the text

 

[Noz2k]

Anyone have any idea?

I think the problem is that it's only doing it for 1 cell. Think somewhere in the code it needs to loop through the range so that the activecell changes.

 

[Noz2k]

Ok, so I got it working using a different code, which I found, created by Gord Dibben.

I think the above code I tried might work too, just you need to place it in the Worksheet_Change module of the sheet, where as I had it on Worksheet_Activate

Anyway, for anyone referring back to this at a later date, the code I ended up using was:

Private Sub Worksheet_Change(ByVal Target As Range) 
Dim NewRwHt As Single 
Dim cWdth As Single, MrgeWdth As Single 
Dim c As Range, cc As Range 
Dim ma As Range 
Dim ProtectStatus As Boolean 

With Target 
If .MergeCells And .WrapText Then 
ProtectStatus = Me.ProtectContents 
If ProtectStatus Then Me.Unprotect  "password" 
Set c = Target.Cells(1, 1) 
cWdth = c.ColumnWidth 
Set ma = c.MergeArea 
For Each cc In ma.Cells 
MrgeWdth = MrgeWdth + cc.ColumnWidth 
Next 
Application.ScreenUpdating = False 
On Error Resume Next 
ma.MergeCells = False 
c.ColumnWidth = MrgeWdth 
c.EntireRow.AutoFit 
NewRwHt = c.RowHeight 
c.ColumnWidth = cWdth 
ma.MergeCells = True 
ma.RowHeight = NewRwHt 
cWdth = 0: MrgeWdth = 0 
On Error GoTo 0 
Application.ScreenUpdating = True 
If ProtectStatus Then Me.Protect "password" 
End If 
End With 
End Sub

Where you replace the word password with your protect sheet password.

 

[Latchmaker]

The Last code posted locks the merged cells in Excel 2003 is there a code to prevent this that can be added to the above code?

 

[hconfer]

Thank you for the code!!! It saved a ton of frustration with excel.

 

[mistersend]

Thank you for the code. It works great!

The code autofit the row height of all merged cells with wrap text on. I want to exclude some merged cells from autofit, without turning the wrap text off. Please help if possible.