Worksheet_Change even code will not run

[retseort]

Ok, this code would run if used in Worksheet Selection Change but it would only autofit the merged cells if I exited and then re-enterd the cell. I want it to autofit merged cells upon text entry or exiting the cell.

Please take a look and tell me why it does nothing.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.EnableEvents = False
ActiveCell = Target.Column
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MeregedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
Application.EnableEvents = True
End If
End With
End If
End Sub

 

[al_b_cnu]

Hi,

Without understanding your code, have you quit from the macro, leaving EnableEvents set to False? - try closing your w/book & re-opening.

 

[retseort]

Just tried it...did not help..

 

[al_b_cnu]

Hi,

Tidied up your code, moved the application.enableevents=true, also corrected the spolling mistook ("MeregedCellRgWidth "), it now sets the first cell of the changed range to the column ( )

What were you trying to achieve?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.EnableEvents = False
ActiveCell = Target.Column

If ActiveCell.MergeCells Then
    With ActiveCell.MergeArea
        If .Rows.Count = 1 And .WrapText = True Then
            Application.ScreenUpdating = False
            CurrentRowHeight = .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(CurrentRowHeight > PossNewRowHeight, _
                             CurrentRowHeight, PossNewRowHeight)
        End If
    End With
End If
Application.EnableEvents = True
End Sub

 

[retseort]

I need the code to take the sheet it is assigned to and every time a user enters text in merged cells it autofits the cell or row so that all text is visible. I will take a look at your changes. Thanks

 

[al_b_cnu]

Hi,

If you remove the activecell=target.column, it seems to work ok:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.EnableEvents = False
'ActiveCell = Target.Column

If ActiveCell.MergeCells Then
    With ActiveCell.MergeArea
        If .Rows.Count = 1 And .WrapText = True Then
            Application.ScreenUpdating = False
            CurrentRowHeight = .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(CurrentRowHeight > PossNewRowHeight, _
                             CurrentRowHeight, PossNewRowHeight)
        End If
    End With
End If
Application.EnableEvents = True
End Sub

 

[retseort]

Weird, I pasted it in and it doesn't work.

Here is the code as seen in my spreadsheet. It is assigned to the sheet it should affect I am using XL2000

Private Sub Worksheet_Change(ByVal Target As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.EnableEvents = False
'ActiveCell = Target.Column
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .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(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
Application.EnableEvents = True
End Sub

 

[al_b_cnu]

Weird indeed!

I actually wrote a quick sub
Sub Enable()
Application.enableevents=true
end sub

which I called if I ever exitted from the worksheet change event.

Thinking about it, why do you need the application.enableevents=False anyway - you dont actually change a cell.

 

[retseort]

I thought you had indicated you got it to work. I copied it into a blank spreadsheet and tried it and still nothing. I guess I am out of options.

Thanks for trying [/img][/url]

 

[retseort]

Alan or anyone else got any ideas on this issue?

Issue: Ok, this code would run if used in Worksheet Selection Change but it would only autofit the merged cells if I exited and then re-enterd the cell. I want it to autofit merged cells upon text entry or exiting the cell.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Application.EnableEvents = False
'ActiveCell = Target.Column

If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .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(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
Application.EnableEvents = True
End Sub