Wrap Text code with merge cells
OK this is the code I have form my previous question he
It works great BUT has one problem. When it does its job and expends the row
to fit the text in one cell, then when I go to the next cell and type
something smaller it overwrights the first cell also. How can I fix this
CODE
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
ActiveSheet.Unprotect Password:="eli"
With Target
If .MergeCells And .WrapText Then
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
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
Application.ScreenUpdating = True
End If
End With
Range("B31:O98").Locked = False
With ActiveSheet
.Protect Password:="eli"
.EnableSelection = xlUnlockedCells
End With
End Sub
|