# VBA code slowing workbook

I have a spreadsheet with five sheets all of which run the same VBA code; everything was good when it was on just the one sheet, but now it's running on all five sheets Excel is extremely slow to load and the items take a while to update.

I have a drop down menu in one column and if a user selects an item from this list it updates the next two cells with their username and date and time stamps it. I have 12 sections on each sheet for each month of the year.

I'm a VBA newbie but I adapted this code from another website with a little trial and error. Is there a way I can speed things up?

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 1 Or Target.Column = 2 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("D" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("C" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("C:D").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 5 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("G" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("F" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("F:G").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 8 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("J" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("I" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("I:J").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 11 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("M" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("L" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("L:M").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 14 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("P" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("O" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("O:P").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 17 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("S" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("R" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("R:S").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 20 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("V" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("U" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("U:V").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 23 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("Y" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("X" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("X:Y").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 26 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("AB" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("AA" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("AA:AB").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 29 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("AE" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
End If
If Target.Column = 1 Or Target.Column = 32 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("AH" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("AG" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("AG:AH").EntireColumn.AutoFit
End If
If Target.Column = 1 Or Target.Column = 35 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
' time stamp corresponding to cell's last update
Range("AK" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("AJ" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("AK:AJ").EntireColumn.AutoFit
End If
End Sub

• In general, Worksheet_Change is NOT performance friendly Jan 25 '19 at 17:48
• Biggest speed issue, is the fact that this code will run 3 times...once when the user changes a cell, once when you write the date and once when you write the username...more to follow Feb 4 '19 at 16:15

The first two points I want to make in this review are general ones that are good discipline to aid in any maintenance.

• Always use Option Explicit. Always. At the very least, it will encourage strong type checking and help avoid any nuisance errors caused by spelling errors.
• Always indent your code properly. This will help any reader identify logical blocks.

I can see from your above code that you have done neither. This makes the code harder to read, thus harder to review.

The next point is also a common one - Don't Repeat Yourself (DRY). In your code you have a repetitive theme:

Range("D" & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range("C" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("C:D").EntireColumn.AutoFit


Repeated blocks identify two methods for improvement - either a stand-alone routine or a loop. Because your code logic is based on the conditional location of the change, I advocate for a stand-alone routine here (in this case, a Sub, not a Function):

Sub MakeMyAmendments(rangeToAmend as Range) ** See notes below
rangeToAmend(1).Value = Environ("username") & "|" & Application.UserName
rangeToAmend(2).Value = Now()
rangeToAmend.EntireColumn.Autofit
End Sub


Notes:

1. Name this sub something sensible, something that fits in with your logic flow
2. I could have approached this a number of ways - such as passing in the address rather than the range, passing in the row number, passing in any other factors.
3. For me the easiest and simplest way was simply to let the logic in the main event handler identify what had to be changed.

This reduces the main event handler to:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 1 Or Target.Column = 2 Then
'ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
'MakeMyAmendments Target.Worksheet.Range("C" & ThisRow & ":D" & ThisRow) ' Option 1 - following closely to the original
'MakeMyAmendments Target.Worksheet.Range("C" & Target.Row & ":D" & Target.Row) ' Option 2, negating need for the additional variable
With Target.Worksheet
MakeMyAmendments .Range(.Cells(Target.Row,3),.Cells(Target.Row,4))
End With - preferred, fully qualified and makes the next logic leap easier to see.
End If
If Target.Column = 1 Or Target.Column = 5 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
With Target.Worksheet
MakeMyAmendments .Range(.Cells(Target.Row,6),.Cells(Target.Row,7))
End With
End If
If Target.Column = 1 Or Target.Column = 8 Then
ThisRow = Target.Row
If (ThisRow = 1) Then Exit Sub
With Target.Worksheet
MakeMyAmendments .Range(.Cells(Target.Row,9),.Cells(Target.Row,10))
End With
End If
' Repeat: 11 gives us 12 & 13 ' Yeah, I am getting bored with this.
' Repeat: 14 gives us 15 & 16
' Repeat: 17 gives us 18 & 19
' Repeat: 20 gives us 21 & 22
' Repeat: 23 gives us 24 & 25
' Repeat: 26 gives us 27 & 28
' Repeat: 29 gives us 30 & 31
' Repeat: 32 gives us 33 & 34
' Repeat: 35 gives us 36 & 37
End Sub


You can see a clear pattern here. But, what happens if you want to expand to the right - just keep adding more "If" statements?

And your logic is non-intuitive (a subtle trap that I missed on the first reading). If the Column = 1 then you want to amend all the other columns, but if the Column = anything other than that, then only amend the one set. So now we have to understand the full collection.

And if my statement above is wrong - then you certainly have a problem in your code - refer to my first points about making the logic easier to see.

How do we describe the pattern. I think one way is to set up an array. Another way is to use a formula to reflect the 3-based pattern - but I think an array is the easiest to see and maintain.

Again, this is an example of DRY - in this case we can use a loop.

Dim iterator as Long ' always long
For iterator = 2 to 35 Step 3 ' this will include the first and last columns, so easy to amend if the number of data points change.
If Target.Column = 1 Or Target.Column = Iterator Then
With Target.Worksheet
MakeMyAmendments .Range(.Cells(Target.Row,iterator+1),.Cells(Target.Row,iterator+2))
End With
End If
Next iterator


Putting all this together:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim iterator as Long ' always long
For iterator = 2 to 35 Step 3 ' this will include the first and last columns, so easy to amend if the number of data points change.
If Target.Column = 1 Or Target.Column = Iterator Then
With Target.Worksheet
MakeMyAmendments .Range(.Cells(Target.Row,iterator+1),.Cells(Target.Row,iterator+2))
End With
End If
Next iterator
End Sub


This creates a simple and maintainable event handler. It will also be easier to add further logic for different change rules as a new logic block because you are now not dealing with lots of lines of code.

What can we do to slightly speed this up? Calls to Excel Objects incur an overhead because the VBA has to switch from the VBA model to the Excel model (referencing and de-referencing) every time we reference the object. We can minimise those switches for those items we know that will not change:

Dim targetColumn as Long
Dim targetRow as Long
targetColumn = Target.Column
targetRow = Target.Row


Throwing this in adds a few lines, but will save time (not much in this case but could add up if you are looking at 100s of columns).

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim targetColumn as Long
Dim targetRow as Long
targetColumn = Target.Column
targetRow = Target.Row

Dim iterator as Long ' always long
For iterator = 2 to 35 Step 3 ' this will include the first and last columns, so easy to amend if the number of data points change.
If targetColumn = 1 Or targetColumn = Iterator Then
With Target.Worksheet
MakeMyAmendments .Range(.Cells(targetRow ,iterator+1),.Cells(targetRow ,iterator+2))
End With
End If
Next iterator
End Sub


In this case, creating an object to represent the Target.Worksheet is unlikely to make any difference. But should always consider it!

All code in this answer is untested.

• Thank you for your extensive commentary. It is very useful. I have never used VBA before doing the code I adapted above; I can see VBA is going to be very useful and make my life easier, but at present I think I need to do some more reading and experimenting. Much of what you have coded above makes sense, but I'm not sure I get it all yet! :-)
– Ben
Jan 28 '19 at 10:15
• To tag onto @AJD's note about indentation, here's a handy Smart Indenter tool that you can use for existing code, or to double-check while you're learning - rubberduckvba.com/Indentation Jan 28 '19 at 21:30
• Instead of the iterator, just use the mod function....If targetColumn mod 3 = 2 then Feb 4 '19 at 16:08
• @Profex: the loop (iterator) is still needed and the use of mod obscures the start and end column. While the suggestion is really good for other cases, in this case the simplicity of the statement helps the OP.
– AJD
Feb 4 '19 at 18:27

In addition to all the great advice in the other answers, specifically about always using Option Explicit and the DRY principle...

What happens when someone pastes multiple cells at once (instead of using the down down)?

Typically I use a For Each cell in Target followed by a Select Case Cell.Column.

It handles the pasting of multiple cells at once (where your code only deals with the first cell) and is much easier to read.

There are also a few Application variables that you can change to speed things up. The main one, that should almost be a requirement for the Worksheet_Change function is:

Application.EnableEvents.

If you don't turn this off while you make changes to the current worksheet, you could get stuck in an endless loop.

Anyway, this is the basic idea of what I end up using...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim isActiveWindow As Boolean
Dim InitialScreenUpdating As Boolean, InitialEnableEvents As Boolean, InitialCalculation As Boolean
Dim DataRange As Excel.Range, Cell As Excel.Range

' Get current State
isActiveWindow = Not ActiveWindow Is Nothing
' Can't reference Application.Calculation unless a Window is active
If isActiveWindow Then InitialCalculation = Application.Calculation
InitialEnableEvents = Application.EnableEvents
InitialScreenUpdating = Application.ScreenUpdating

' In case anything goes wrong, we need a safe exit...
On Error GoTo ErrHandler

' Turn off Automatic Calculation mode...if changing a lot of values that are referenced in formulas
If isActiveWindow Then Application.Calculation = xlCalculationManual
' Turn off All Events...such as Worksheet_Change.
' Make sure that you turn it back on (specificaly when debugging and you stop the code, no events will trigger)
Application.EnableEvents = False
' Pause screen rendering, to speed up code if there are lots of changes (doesn't apply while debugging)
Application.ScreenUpdating = False

' Limit the Target to the range that you care about...
' in this case anything but the first row
Set DataRange = ActiveSheet.Range("2:" & ActiveSheet.Rows.Count)
Set Target = Intersect(Target, DataRange)

' Just in case there are multiple cells changed...
For Each Cell In Target
Select Case Cell.Column
Case 1
' Do something
Case Else
If Cell.Column Mod 3 = 2 Then
' Do something else
End If
End Select
Next

ErrHandler:
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Number & vbCr & vbCr & Err.Description
End If

' Restore States to what it was at the start
isActiveWindow = Not ActiveWindow Is Nothing
' Can't reference Application.Calculation unless a Window is active, hence the nested If statements
If isActiveWindow Then _
If Application.Calculation <> InitialCalculation Then _
Application.Calculation = InitialCalculation
If Application.EnableEvents <> InitialEnableEvents Then _
Application.EnableEvents = InitialEnableEvents
If Application.ScreenUpdating <> InitialScreenUpdating Then _
Application.ScreenUpdating = InitialScreenUpdating
' You could just set these, but if this is added to nested functions,
' you wouldn't want to cause unnecessary flickering.
End Sub


In reality, and because of DRY, you would want to create a function to clean it up so that it would look something like this...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim AppState As AppStateType
On Error GoTo ErrorHandler
AppState = ChangeAppState(AppState, -1, True, True)

' Do stuff here

ErrorHandler:

EndSub:
ChangeAppState AppState, , True, True
End Sub


Where I have a public User Defined Type:

Public Type AppStateType
ScreenUpdating As Boolean
DisplayStatusBar As Boolean
Calculation As Integer
EnableEvents As Boolean
End Type


and the ChangeAppState Function

' Turn ScreenUpdating off for speed, while writing values to the cells.
' Turn EnableEvents off to disable the SheetChange Events from firing while updating values.
' Turn Calculation to xlCalculationManual for speed while updating values.
Function ChangeAppState(AppState As AppStateType, Optional State As Integer, _
Optional SetScreenUpdating As Boolean, Optional SetEnableEvents As Boolean, _
Optional SetCalculation As Boolean, Optional SetDisplayStatusBar As Boolean) As AppStateType
Dim bActiveWindow As Boolean
' Change the Application States to False/Manual if State is -1
' Change the Application States back to the the values in AppState if State is 0
' Change the Application States to True/Automatic if State is 1
bActiveWindow = Not ActiveWindow Is Nothing
ChangeAppState.ScreenUpdating = Application.ScreenUpdating
ChangeAppState.DisplayStatusBar = Application.DisplayStatusBar
If bActiveWindow Then ChangeAppState.Calculation = Application.Calculation
ChangeAppState.EnableEvents = Application.EnableEvents
Select Case State
Case -1
If SetScreenUpdating And Application.ScreenUpdating <> False _
Then Application.ScreenUpdating = False
If SetEnableEvents And Application.EnableEvents <> False _
Then Application.EnableEvents = False
If bActiveWindow Then _
If SetCalculation And Application.Calculation <> xlCalculationManual _
Then Application.Calculation = xlCalculationManual
If SetDisplayStatusBar And Application.DisplayStatusBar <> False _
Then Application.DisplayStatusBar = False
Case 0
If SetDisplayStatusBar And Application.DisplayStatusBar <> AppState.DisplayStatusBar _
Then Application.DisplayStatusBar = AppState.DisplayStatusBar
If bActiveWindow Then _
If SetCalculation And Application.Calculation <> AppState.Calculation _
Then Application.Calculation = AppState.Calculation
If SetEnableEvents And Application.EnableEvents <> AppState.EnableEvents _
Then Application.EnableEvents = AppState.EnableEvents
If SetScreenUpdating And Application.ScreenUpdating <> AppState.ScreenUpdating _
Then Application.ScreenUpdating = AppState.ScreenUpdating
Case 1
If SetScreenUpdating And Application.ScreenUpdating <> True _
Then Application.ScreenUpdating = True
If SetEnableEvents And Application.EnableEvents <> True _
Then Application.EnableEvents = True
If bActiveWindow Then _
If SetCalculation And Application.Calculation <> xlCalculationAutomatic _
Then Application.Calculation = xlCalculationAutomatic
If SetDisplayStatusBar And Application.DisplayStatusBar <> True _
Then Application.DisplayStatusBar = True
End Select
End Function


The AutoFit function is probably going to be one of the slowest operations that you have. The above code should help speed it up. If it doesn't, you may want/need to do the following

• create a new temporary sheet in the background
• Autofit the new sheet

If those columns are larger then the ones in the original sheet, you would

• adjust the original sheet's columns
• delete the temporary sheet.

Just make sure the font/size & sheet zoom are the same.

This is untested but is this any faster ?

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
column = Target.Column
ThisRow = Target.Row

If (column <> 1 Or ThisRow = 1) Then Exit Sub

startColumn = Col_Letter(Target.Column + 1)
endColumn = Col_Letter(Target.Column + 2)

' time stamp corresponding to cell's last update
Range(endColumn & ThisRow).Value = Now
' Windows level UserName | Application level UserName
Range(startColumn & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range(startColumn & ":" & endColumn).EntireColumn.AutoFit
End Sub

' taken from https://stackoverflow.com/questions/12796973/function-to-convert-column-number-to-letter
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "\$")
Col_Letter = vArr(0)
End Function
`