VBA code slowing workbook

Question

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
Range("AD" & ThisRow).Value = Environ("username") & "|" & Application.UserName
Range("AD:AE").EntireColumn.AutoFit
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

Answer 1

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.

Answer 2

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

In addition

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
• add the same username/date values
• 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.

Answer 3

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