Word wrapping merged cells

[Alex]

I have the following code in my worksheet that word wraps merged cells. It
wraps the cell contents fine after a user types in the cells and clicks
enter. The problem is that it then protects the cells, so then a user cannot
edit the contents in the cells because they are protected. Can I change this
code so that it doesn't protect the cells after word wrapping? Also, I need
to wrap cells F12:F15 as well. How can I include those merged cells in the
code below. Thanks for your help.

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

ActiveSheet.Unprotect Password:="abcde"

Dim RowHt As Single, MergeWidth As Single
Dim C As Range, AutoFitRng As Range
Dim CWidth As Single, NewRowHt As Single
Static OldRng As Range

ActiveSheet.Unprotect Password:="abcde"
On Error Resume Next
If OldRng Is Nothing Then _
Set OldRng = Range("B31").MergeArea
Set AutoFitRng = Range("B31:I33")
If Not Intersect(OldRng, AutoFitRng) Is Nothing Then
Application.ScreenUpdating = False
With OldRng
RowHt = .RowHeight
CWidth = .Cells(1).ColumnWidth
For Each C In OldRng
MergeWidth = C.ColumnWidth + MergeWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergeWidth
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = CWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
Application.ScreenUpdating = True
End If
Set OldRng = Target

ActiveSheet.Protect Password:="abcde"

End Sub

 

[Tom Ogilvy]

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

' ActiveSheet.Unprotect Password:="abcde"

Dim RowHt As Single, MergeWidth As Single
Dim C As Range, AutoFitRng As Range
Dim CWidth As Single, NewRowHt As Single
Static OldRng As Range

On Error Resume Next
If OldRng Is Nothing Then _
Set OldRng = Range("B31").MergeArea
Set AutoFitRng = Range("B31:I33")
If Not Intersect(OldRng, AutoFitRng) Is Nothing Then

if Activesheet.ProtectContents then
ActiveSheet.Unprotect Password:="abcde"
end if

Application.ScreenUpdating = False
With OldRng
RowHt = .RowHeight
CWidth = .Cells(1).ColumnWidth
For Each C In OldRng
MergeWidth = C.ColumnWidth + MergeWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergeWidth
.EntireRow.AutoFit
NewRowHt = .RowHeight
.Cells(1).ColumnWidth = CWidth
.MergeCells = True
.RowHeight = NewRowHt
End With
Application.ScreenUpdating = True
End If
Set OldRng = Target

' ActiveSheet.Protect Password:="abcde"

End Sub

Why not make a copy of the code and adjust it for F12:15 and run it once. I
don't see that you would need to include that in the change event.