Speed this VBA Up?

Question

Is there a way to speed this code up? I need it to remove and write the same content to the cell to force other VBA code to run that's on another column. Which is what it does, just super damn slow. And there is sometimes 2000 entries/rows on this sheet. Its about 3 seconds per cell, and it almost maxes my CPU out lol. (i7 6850k @ 4.4ghz).

Reason for it, is sometimes the data is copied from an old version of the spreadsheet to a new version, and the VBA updated columns wont update, unless I physically change the cell its checking.

Sub ForceUpdate()
    On Error GoTo Cleanup
    Application.ScreenUpdating = False ' etc..
    ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
    Dim cell As Range, r As Long
    r = 2
    For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
        If Len(cell) > 0 Then
            Dim old As String
            old = cell.Value
            ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
            ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
            r = r + 1
        End If
    Next cell
Cleanup:
    Application.ScreenUpdating = True ' etc..
    ThisWorkbook.Sheets("Sales Entry").Protect "password!", _  
        AllowSorting:=True, AllowFiltering:=True
End Sub

The code in the other VBA section is

If StrComp("pp voice", Target.Value, vbTextCompare) = 0 Then
    Target.Value = "PP Voice"
    Target.Offset(0, 8).Value = "N\A"
    Target.Offset(0, 8).Locked = True
    Target.Offset(0, 10).Value = "N\A"
    Target.Offset(0, 10).Locked = True
End If

Target.Value is referring to the E column in the first piece of code. At the moment I have the first piece attached to a button, but it's way to slow. And the target machines are no where near as powerful as mine.

What you really want to do is go post this on [Code Review](https://codereview.stackexchange.com/) where they are focused on reviewing / optimising code which is working. What will possibly help is using an `Array` which will get the data from the sheet and then you can process the `Array` and then send the data to the new sheet. — Jean-Pierre Oosthuizen, Jul 21 '17 at 12:50
Use application.enableevent = false and application.calculation = xlcalculationmanual. Turn them back on before exiting. You must be either triggering an large event or complex calculation cycle if it it taking 3 seconds per cell. — , Jul 21 '17 at 13:21

score 3 · Answer 1 · answered Jul 21 '17 at 13:26

3

Use application.enableevents = false and application.calculation = xlcalculationmanual. Turn them back on before exiting. You must be either triggering an large event or complex calculation cycle if it it taking 3 seconds per cell.

Change,

Dim cell As Range, r As Long
r = 2
For Each cell In ThisWorkbook.Sheets("Sales Entry").Range("E2:E10")
    If Len(cell) > 0 Then
    Dim old As String
    old = cell.Value
    ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = ""
    ThisWorkbook.Sheets("Sales Entry").Range("E" & r).Value = old
    r = r + 1
    End If
Next cell

... to,

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim cell As Range
With ThisWorkbook.Sheets("Sales Entry")
    For Each cell In .Range("E2:E10")
        If CBool(Len(cell.Value2)) Then
            cell = cell.Value2
        End If
    Next cell
End With

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

answered Jul 21 '17 at 13:26

Not sure if I got your loop right; you were only iterating `r` inside your `If` meaning that some values may be passed upwards. I removed that. – Jul 21 '17 at 13:28
Had to comment out the top Enable events, and modified the range to go to the bottom row with data. Works, screen hangs while it does it, CPU doesn't go nuts however. And once Excel has done its thing, everything has worked. Not ideal, but it will do for how rarely the button will be pressed. – Ben Logan Jul 22 '17 at 05:07
Strange, running this code on the work machines (pretty sure its 2013), is so much faster, almost instant than on my machine running 2016. – Ben Logan Jul 23 '17 at 01:08
Do you have 64-bit Excel on a 64-bit OS on the work machine but only 32-bit Excel on a 64-bit OS on your personal? – Jul 23 '17 at 16:07
32 for both at work I'm fairly sure, 64 on personal. – Ben Logan Jul 23 '17 at 20:36
But I do have Visual Studio 15 and 17 installed on my personal, see if any addins have made their way into Office. – Ben Logan Jul 24 '17 at 05:49

Jean-Pierre Oosthuizen · Answer 2 · 2017-07-24T07:28:46.133

Try this

Option Explicit

Sub ForceUpdate()


    On Error GoTo Cleanup
    Dim SalesEntrySheet As Worksheet
    Set SalesEntrySheet = ThisWorkbook.Sheets("Sales Entry")

    Application.ScreenUpdating = False ' etc..


    SalesEntrySheet.Unprotect "password!"

    Dim cell As Range, r As Long
    Dim ArrayPos As Long
    Dim SalesEntrySheetArray As Variant

    With SalesEntrySheet
        'Starting with row one into the array to ease up the referencing _
            so Array entry 2 will be for row 2
        SalesEntrySheetArray = .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)

        'Clearing the used range in Col E
        'If you are using a WorkSheet_Change for the second part of your code then you should rather make this a loop
        .Range("E1:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value = ""

        'Putting the values back into the sheet
        For ArrayPos = 2 To UBound(SalesEntrySheetArray, 1)

            .Cells(ArrayPos, "E").Value = SalesEntrySheetArray(ArrayPos, 1)

        Next ArrayPos

    End With

    Cleanup:
    Application.ScreenUpdating = True ' etc..
    ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, _
    AllowFiltering:=True

End Sub

While this is super fast, all it's doing is clearing the column. — Ben Logan, Jul 22 '17 at 04:31
@BenLogan, I thought to clear all the cells first to save a line of execution in the loop. — Jean-Pierre Oosthuizen, Jul 24 '17 at 06:06
@BenLogan apologies, I missed the dimension level for the array. Try it now — Jean-Pierre Oosthuizen, Jul 24 '17 at 07:29

score 0 · Answer 3 · answered Jul 21 '17 at 12:43

Try to use with statement. and take a look at Optimizing VBA macro

Sub ForceUpdate()
On Error GoTo Cleanup
Application.ScreenUpdating = False ' etc..
ThisWorkbook.Sheets("Sales Entry").Unprotect "password!"
Dim cell As Range, r As Long
r = 2
With ThisWorkbook.Sheets("Sales Entry")
    For Each cell In .Range("E2:E10")
        If Len(cell) > 0 Then
        Dim old As String
        old = cell.Value
        .Cells(4, r) = ""
        .Cells(4, r) = old
        r = r + 1
        End If
    Next cell
End With
Cleanup:
Application.ScreenUpdating = True ' etc..
ThisWorkbook.Sheets("Sales Entry").Protect "password!", AllowSorting:=True, AllowFiltering:=True
End Sub

Speed this VBA Up?

3 Answers3