patternMinor
Ignore exceptions when changing column formula in Excel table
Viewed 0 times
ignoreexceptionsexcelcolumnwhenchangingformulatable
Problem
The new table feature on Excel is excellent and you can specify a column formula as well as exceptions on the column. However, if you want to change the column formula, Excel will rewrite the whole column including the exceptions. I've tried to avoid this issue with the following code:
```
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
'Prevent from firing if changed cell is outside a table
If Target.ListObject Is Nothing Then Exit Sub
'Prevent from firing if cell is changed to a value
If Val(Target.Formula) = Target.Value Then Exit Sub
'Prevent from firing if multiple cells where changed
If Target.Count > 1 Then Exit Sub
'Disable events
ToggleWaitMode
'Prevent change if user already stated calculation as manual
Dim bCheckCalculationMode As Boolean
If Application.Calculation = xlCalculationAutomatic Then
Application.Calculation = xlCalculationManual
bCheckCalculationMode = True
End If
'Declarations
Dim sTableName As String
Dim lNbLines As Long
Dim i As Long
Dim sFieldName As String
Dim cel As Range
Dim sOldFormula As String
Dim sNewFormula As String
Dim aExceptionFormulas() As String
Dim aExceptionAddresses() As String
sTableName = Target.ListObject.Name
lNbLines = Range(sTableName).Rows.Count
sFieldName = "[" & Intersect(Target.ListObject.HeaderRowRange, Target.EntireColumn).Value & "]"
'Add a new row to get the column formula
Range(sTableName).ListObject.ListRows.Add
sOldFormula = Range(sTableName & sFieldName)(lNbLines).Formula
sNewFormula = Target.Formula
'Loop on each cell of the column to get each exception formulas and addresses in arrays
i = 1
For Each cel In Range(sTableName & sFieldName)
If cel.Formula <> sOldFormula Then
ReDim Preserve aExceptionFormulas(1 To i)
ReDim Preserve aExceptionAddresses(1 To i)
aExceptionFormulas(i) = c
```
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
'Prevent from firing if changed cell is outside a table
If Target.ListObject Is Nothing Then Exit Sub
'Prevent from firing if cell is changed to a value
If Val(Target.Formula) = Target.Value Then Exit Sub
'Prevent from firing if multiple cells where changed
If Target.Count > 1 Then Exit Sub
'Disable events
ToggleWaitMode
'Prevent change if user already stated calculation as manual
Dim bCheckCalculationMode As Boolean
If Application.Calculation = xlCalculationAutomatic Then
Application.Calculation = xlCalculationManual
bCheckCalculationMode = True
End If
'Declarations
Dim sTableName As String
Dim lNbLines As Long
Dim i As Long
Dim sFieldName As String
Dim cel As Range
Dim sOldFormula As String
Dim sNewFormula As String
Dim aExceptionFormulas() As String
Dim aExceptionAddresses() As String
sTableName = Target.ListObject.Name
lNbLines = Range(sTableName).Rows.Count
sFieldName = "[" & Intersect(Target.ListObject.HeaderRowRange, Target.EntireColumn).Value & "]"
'Add a new row to get the column formula
Range(sTableName).ListObject.ListRows.Add
sOldFormula = Range(sTableName & sFieldName)(lNbLines).Formula
sNewFormula = Target.Formula
'Loop on each cell of the column to get each exception formulas and addresses in arrays
i = 1
For Each cel In Range(sTableName & sFieldName)
If cel.Formula <> sOldFormula Then
ReDim Preserve aExceptionFormulas(1 To i)
ReDim Preserve aExceptionAddresses(1 To i)
aExceptionFormulas(i) = c
Solution
Private Sub Worksheet_Change(ByVal Target As Range)The
Worksheet.Change event gets fired whenever anything changes anywhere in the worksheet. Code you write in a handler for that event must do its business as fast as possible, or it can significantly affect (negatively) the performance of the whole Excel instance.Whenever possible, avoid using this event for anything that doesn't need to run whenever anything changes anywhere in the worksheet.
Application.Calculation = xlCalculationManual
If Target.Count = 1 Then
Application.EnableEvents = FalseYour indentation is off, the assignment
Application.EnableEvents = False should be one Tab further to the right.I like that you're disabling automatic calculation and other worksheet event handlers, but I don't understand why only one of them is under the
If block.Application.EnableEvents = True
End If
ActiveSheet.Calculate
End SubThe result of this is that you're calculating the active sheet, but you've disabled automatic calculation of the workbook without reinstating it, and you end up systematically calling
ActiveSheet.Calculate, which gives the illusion that automatic calculation is still enabled.tb = Target.ListObject.NameIf the modified cell is outside of a
ListObject, this is where your code blows up, and because you're not handling run-time errors, this is where your user sees a VBA debugger prompt and might accidentally end up in your source code with a puzzled facial expression.Whenever you start writing a method/procedure/function in VBA, you should start with something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
'code goes here
CleanExit:
Exit Sub
ErrHandler:
Resume CleanExit
Resume 'unreachable code, for debugging
End SubNow you can put a breakpoint on the
Resume CleanExit instruction, and can inspect the Err object and then set the Resume dead code as the next statement to be executed, and be taken (F8) exactly on the line the error came from, whenever anything goes wrong with this code.Dim tb As String
tb = Target.ListObject.NameIf
tb is supposed to be the name of a table, then why is it not called tableName? Use descriptive identifiers when naming things!Dim l As Long
Dim i As Long
Dim s As String
Dim cel As Range
Dim fmla As String
Dim nfmla As String
Dim mfmla() As String
Dim mad() As StringOh, boy. Need I say more?
I'm not going to review your algorithm (not going to try to wrap my head around those cryptic identifiers), but one thing I can say is that, for the reasons explained at the top of this answer, I'd start the procedure like this:
If Target.ListObject Is Nothing Then Exit SubThat way you don't bother with anything if the active cell isn't in a table, and the handler can't blow up either when you later try to get the table's name.
Also by only testing for
Target.Count = 1 all you're really doing, is ensuring that the current selection only has a single cell. This means if a user selects an entire row (or column) and starts entering data, your code happily sets calculation mode to manual, skipts the entire handler and recalculates the sheet.Hence, the next thing I'd do after ensuring the
Target range has a ListObject, would be to toggle calculation mode and event firing. It's probably best to write a small procedure just for that:Private Sub ToggleWaitMode(Optional ByVal wait As Boolean = True)
Application.Calculation = IIf(wait, xlCalculationManual, xlCalculationAutomatic)
Application.EnableEvents = Not wait
Application.AutoCorrect.AutoFillFormulasInLists = Not wait
End SubThat leaves your handler with pretty much only the code that's relevant for its task:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If Target.ListObject Is Nothing Then Exit Sub
ToggleWaitMode
'...
CleanExit:
ToggleWaitMode False
Exit Sub
ErrHandler:
Resume CleanExit
Resume 'unreachable code, for debugging
End SubI don't like the
ReDim Preserve array handling. You know how many cells you're going to be iterating over (Range(tb & s).Count), therefore you know the size of the array you're going to need at the moment you're declaring it. You'll probably gain some performance by doing this, depending on how many cells the range has.Code Snippets
Private Sub Worksheet_Change(ByVal Target As Range)Application.Calculation = xlCalculationManual
If Target.Count = 1 Then
Application.EnableEvents = FalseApplication.EnableEvents = True
End If
ActiveSheet.Calculate
End Subtb = Target.ListObject.NamePrivate Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
'code goes here
CleanExit:
Exit Sub
ErrHandler:
Resume CleanExit
Resume 'unreachable code, for debugging
End SubContext
StackExchange Code Review Q#55002, answer score: 6
Revisions (0)
No revisions yet.