Excel VBA processing getting slower and slower the longer it runs

Question

I have a code created and need your support to optimize it. VBA analyses spreadsheet for 6 dates located in columns (milestones) and defines the latest date, column name and status if there is any status next to date column. As a result VBA pastes this data to additional columns located in same sheet and called:

Current Milestone
Date
Status

Problem is when I run this VBA for a spreadsheets with small amount of lines it runs well but bigger the amount of lines slower it operates. I have calculated that 7400 lines (50 min to run VBA) produce result with 10 times less lines/min speed comparing to 460 lines (20 sec to run VBA) and difference get bigger together with amount of lines in spreadsheet.

Before the VBA is run I always run short VBA to switch off automatic calculation EXP.EnableCalculation = False as example for this sheet. I replicate same line for all spreadsheets in my workbook. At the moment WB has 77 spreadsheets. Some of them have raw data and some contain formula based summary tables with reference to raw data. Overall file size is over 25Mb. File format is *.XLSB

Below is the code sample I use.

Appreciate your help in advance!

Sub D_13_Exp_LAM()

Application.ScreenUpdating = False

Sheets("Exp").Activate
ActiveWindow.FreezePanes = False
Range("A:PA").EntireColumn.Hidden = False

Dim today As Date
today = Date

'============= Exp =====================
T = 52
Do While Worksheets("Exp").Cells(1, T).Value <> ""
Select Case Worksheets("Exp").Cells(1, T)
Case "MS 11.6 Site Integration Completed [AC]"
Case "MS 11.8 Site On-Air [AC]"
Case "MS 11.9.1 Technical part of PAC ready [AC]"
Case "MS 11.9.2 Technical part of PAC approved [AC]"
Case "MS 11.10 PAC Issued [AC]"
Case "MS 13.1 FAC Issued [AC]"

Case Else
     Worksheets("Exp").Columns(T).Hidden = True
End Select
T = T + 1
Loop

 i = 2
 Do While Worksheets("Exp").Cells(i, 1).Value <> ""


 'When SITEID & Phase & Scope create unique character line
 SITEID = Worksheets("Exp").Cells(i, 1)
 Phase = Worksheets("Exp").Cells(i, 2)
 Scope = Worksheets("Exp").Cells(i, 3)
 Unique_Key = SITEID & "_" & Phase & "_" & Scope


 'When SITEID & Phase & Scope does not match, put No_Information
 Worksheets("Exp").Cells(i, 5) = "No_Info"

 'Initialize TowerCo type
 Worksheets("Exp").Cells(i, 6) = ""

 'Move Scope sheet
 j = 2
 Region_Column = Worksheets(Scope).Cells.Find(What:="QROI RO Zone").Column

 Phase_Column = 2

 Do While Worksheets(Scope).Cells(j, 1).Value <> ""
   SITEID_name = Worksheets(Scope).Cells(j, 1)
   Phase_name = Worksheets(Scope).Cells(j, Phase_Column)
   Unique_Key_name = SITEID_name & "_" & Phase_name & "_" & Scope

   'If there is target site on Scope sheet
   If Unique_Key = Unique_Key_name Then

        'Input Onair Actual on Summary
        Worksheets("Exp").Cells(i, Worksheets("Exp").Cells.Find(What:="QROI RO Zone").Column) = Worksheets(Scope).Cells(j, Region_Column)

    r = 6

    Select Case Scope
    Case "Exp"


'MS 13.1 FAC Issued [AC]
        If Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 13.1 FAC Issued [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 13.1 FAC Issued [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 13.1 FAC Issued [AC]").Column)
'MS 11.10 PAC Issued [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.10 PAC Issued [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.10 PAC Issued [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.10 PAC Issued [AC]").Column)
'MS 11.9.2 Technical part of PAC approved [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.2 Technical part of PAC approved [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.9.2 Technical part of PAC approved [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.2 Technical part of PAC approved [AC]").Column)
'MS 11.9.1 Technical part of PAC ready [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.1 Technical part of PAC ready [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.9.1 Technical part of PAC ready [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.9.1 Technical part of PAC ready [AC]").Column)
'MS 11.8 Site On-Air [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.8 Site On-Air [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.8 Site On-Air [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.8 Site On-Air [AC]").Column)
'MS 11.6 Site Integration Completed [AC]
        ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.6 Site Integration Completed [AC]").Column) <> "" Then
            Worksheets("Exp").Cells(i, r) = "MS 11.6 Site Integration Completed [AC]"
            Worksheets("Exp").Cells(i, r + 1) = Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 11.6 Site Integration Completed [AC]").Column)

         End If

    End Select

    '====Past Days calucuration on Current Milestone====
    'Current Status
    latest_status = Worksheets("Exp").Cells(i, r)

        'No Progress
        If latest_status = "" Then
            Worksheets("Exp").Cells(i, r + 1) = "-"

        'Onair
        ElseIf latest_status = "MS 13.1 FAC Issued Actual" Then
            Worksheets("Exp").Cells(i, r + 3) = "Cong!!!"

        'Approve & reject case
        ElseIf Worksheets("Exp").Cells(i, r + 2) = "N/A" Then
            Worksheets("Exp").Cells(i, r + 3) = "N/A"

        ElseIf Worksheets("Exp").Cells(i, r + 2) > 0 Then
            Worksheets("Exp").Cells(i, r + 3) = today - Worksheets("Exp").Cells(i, r + 1)

        End If

    Exit Do

    End If
j = j + 1
Loop

i = i + 1

Loop

''''Re-appear on hidden cell


Sheets("Exp").Activate
Range("A:PA").EntireColumn.Hidden = False

ActiveSheet.Range("E2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True

Application.ScreenUpdating = True

End Sub

Welcome to Code Review! It sounds like you're crunching quite a lot of data using Excel, have you considered using something like a SQL database (MySQL, MS SQL Server, MS Access, etc.) instead of Excel files? Excel was never designed to replace a database engine and I'd be willing to bet the performance gains would be big. — Phrancis, Apr 11 '18 at 5:36
Good point. Have few things to reply: 1. I know excel and not familiar with other application 2. Current code I use is not prepared by me but I am trying to optimize it with my very limited VBA skills 3. Excel table I use has half of sheets with different level of formulas to digest raw data (including Current Milestone I've mentioned above) 4. I designed this WB to pull information directly from 3rd party database (it cannot be used for purposes defined by me) — VTO, Apr 11 '18 at 7:09
@StephenRauch Thanks for the heads up - I have looked at that before and wasn't sure if it applied to that proposed edit... now I know! — Sᴀᴍ Onᴇᴌᴀ, Apr 11 '18 at 15:19
Please clarify -- exactly how many worksheets are there here? The code you are showing only ever uses the Exp worksheet. You mention that you have 77 worksheets in the workbook -- how is this code supposed to run over the other 76? — Zev Spitz, Apr 12 '18 at 0:49

Zev Spitz · Accepted Answer · 2018-04-12 08:50:44Z

Ideally you should work directly with the data, instead of via the overhead of sheets and cells.

I would suggest doing this with an SQL statement directly against the data, because it allows declaratively relating the data instead of using loops, and also allows referring to the column names instead of the numeric indexes. (Using an array as Raystafarian suggests would also be an improvement.)

Until you are able to make sweeping changes to the code, I would immediately suggest the following quick fixes:

For each row, in order to find which column contains the date of a certain milestone, you are searching the entire spreadsheet for a text value. This search is repeated between 4 and 12 times for each row of every spreadsheet. (NB It doesn't make sense to search the entire spreadsheet for values you know will only be in the first row.)

Consider caching this information. If it doesn't change from sheet to sheet, you can cache it outside the outermost loop; otherwise you should do it inside the outermost loop.

I would suggest using a Scripting Dictionary for this purpose. You add pairs of key (milestone name) and value (column index) to the dictionary, and then later you can pass a key to get back the corresponding value. Add a reference (Tools -> References...) to the Microsoft Scripting Runtime library. Then you can write the following code:

'This only needs to be done once for the entire macro; it should go outside of the outermost loop
Dim milestoneNames As Variant
' on multiple lines, so it is easier to read
milestoneNames = Array( _
    "MS 13.1 FAC Issued [AC]", _
    "MS 11.10 PAC Issued [AC]", _
    "MS 11.9.2 Technical part of PAC approved [AC]", _
    "MS 11.9.1 Technical part of PAC ready [AC]", _
    "MS 11.8 Site On-Air [AC]", _
    "MS 11.6 Site Integration Completed [AC]")

'If the following could be different between worksheets, it should be within the outermost loop
Dim milestoneColumns as New Scripting.Dictionary
Dim firstRow As Range
Set firstRow = Worksheets(Scope).Rows(1)
Dim milestoneName As Variant
For Each milestoneName In milestoneNames
    milestoneColumns(milestoneName) = firstRow.Find(What:=milestoneName).Column
Next

Then, we can replace the calls to .Find with calls to the Dictionary, e.g. the following:

If Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(What:="MS 13.1 FAC Issued [AC]").Column) <> "" Then

can be replaced with:

If Worksheets(Scope).Cells(j, milestoneColumns("MS 13.1 FAC Issued [AC]")) <> "" Then

The code appears to only use one known worksheet at a time. If that is the case, then you can replace every reference to either Worksheets("Exp") or Worksheets(Scope) with the built-in variable which refers to the worksheet -- probably EXP or Exp.

If this is not the case, then you should store the worksheet corresponding to the current scope in a variable:
```
Scope = Worksheets("Exp").Cells(i, 3)
Dim wksScope As Worksheet
Set wksScope = Worksheets(Scope)
```
and replace every use of Worksheets(Scope) with the variable. For example:
```
Phase_name = Worksheets(Scope).Cells(j, Phase_Column)
```
would become:
```
Phase_name = wksScope.Cells(j, Phase_Column)
```

Once you've defined the milestone names in an array, you can consolidate all the If statements into a single For Each loop:

For Each milestoneName In milestoneNames
    Dim cellValue As Variant
    cellValue = wksScope.Cells(j, milestoneColumns(milestoneName)).Value
    If cellValue <> "" Then
        wksExp.Cells(i, r) = milestoneName
        wksExp.Cells(i, r + 1) = cellValue
        Exit For
    End If
Next

A dictionary could work. Side note - Worksheets have a CodeName property - View Properties window (F4) and the (Name) field (the one at the top) can be used as the worksheet name. This way you can avoid Sheets("mySheet") and instead just use mySheet instead of assigning a variable. — Raystafarian, Apr 11 '18 at 20:50

Raystafarian · Accepted Answer · 2018-04-11 05:35:20Z

You can't see it in your code, but you've nested a ton of stuff -

Do While Worksheets("Exp").Cells(i, 1).Value <> ""
    Do While Worksheets(Scope).Cells(j, 1).Value <> ""
        If Unique_Key = Unique_Key_name Then
            Select Case Scope
            Case "Exp"
                'MS 13.1 FAC Issued [AC]
                If Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 13.1 FAC Issued [AC]").Column) <> "" Then
                ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.10 PAC Issued [AC]").Column) <> "" Then
                ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.9.2 Technical part of PAC approved [AC]").Column) <> "" Then
                ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.9.1 Technical part of PAC ready [AC]").Column) <> "" Then
                ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.8 Site On-Air [AC]").Column) <> "" Then
                ElseIf Worksheets(Scope).Cells(j, Worksheets(Scope).Cells.Find(what:="MS 11.6 Site Integration Completed [AC]").Column) <> "" Then
                End If
            End Select

            If latest_status = "" Then
            ElseIf latest_status = "MS 13.1 FAC Issued Actual" Then
            ElseIf Worksheets("Exp").Cells(i, r + 2) = "N/A" Then
            ElseIf Worksheets("Exp").Cells(i, r + 2) > 0 Then
            End If

            Exit Do
        End If
        j = j + 1
    Loop
    i = i + 1
Loop

This spells trouble by itself. But if we also include the fact that you're doing everything on the sheet-

Sheets("Exp").Activate
Range("A:PA").EntireColumn.Hidden = False
Sheets("Exp").Activate
ActiveWindow.FreezePanes = False
Range("A:PA").EntireColumn.Hidden = False
ActiveSheet.Range("E2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True

I'm not surprised it takes hours. And .FIND is one of the slowest procedures you can use. And you use it a lot. Be definite when you can.

I'm not sure why you have the SELECT CASE. I'm not sure why you can't combine conditions. Those are things that have to do with your data. What I can say is that you need arrays.

Arrays

Doing stuff on the sheet is slow. It just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

Just bring your data in, do your thing and then spit it back out -

Application.ScreenUpdating = False
    Dim lastRow As Long
    lastRow = Worksheets("Exp").Cells(Rows.Count, 1).End(xlUp).Row
    Dim lastColumn As Long
    lastColumn = 6 'or whatever
    Dim dataArray As Variant
    dataArray = Worksheets("Exp").Range(Worksheets("Exp").Cells(1, 1), Worksheets("Exp").Cells(lastRow, lastColumn))
    For i = 1 To lastRow
        uniqueKey = dataArray(i, 1) & "_" & datarray(i, 2) & "_" & dataArray(i, 3)
        If dataArray(i, j) = "QROI RO Zone" Then
            datarray(i, x) = dataArray(i, y) 'etc
            'make changes in array
        End If
    Next
    Worksheets("Exp").Range(Worksheets("Exp").Cells(1, 1), Worksheets("Exp").Cells(lastRow, lastColumn)) = dataArray
    Columns(8).Hidden = True
    'other things
Application.ScreenUpdating = True

Obviously this code won't just work, but it does give you an idea on how to rework your macro. It's difficult for me to rewrite it without your data structure being apparent.

I'd be willing to wager that this change alone will bring your processing time to under 1 minute.

Also, as an aside - VBA has a constant - vbNullString that you can use instead of "".

I am afraid I have to admit that my VBA skills are not enough t digest all proposals done by you. Is there any chance I can share a sample file with 1 spreadsheet and 1 VBA code in it? I hope to get the code optimized without me being upgraded to VBA expert... :) — VTO, Apr 11 '18 at 7:13
One more point: once I've deleted all other sheets and run the code it took only 5 min overall to execute it... What are possible root causes for it? — VTO, Apr 11 '18 at 7:25
We here at CR are more than happy to review and give advice, but we'd expect you to at least try to do some of it. There's nothing wrong with doing what you can and coming back with that for another review. — Raystafarian, Apr 11 '18 at 10:07
Here is the file LINK for those who is willing to optimize code above — VTO, Apr 11 '18 at 10:12
Dear Raystafarian, agree with what you say. I will try to do part of it should anybody helps me to revise first code. Actually, I have another 20 VBAs I will have to optimize based on solution for this code. Said but true: I can modify existing code with new conditions but cannot reshape or optimize the code. Therefore, I need to rely on expert support. And here I am with my post :) — VTO, Apr 11 '18 at 10:16

Stack Exchange Network

current community

your communities

more stack exchange communities

Excel VBA processing getting slower and slower the longer it runs

2 Answers 2

Arrays

Your Answer

Not the answer you're looking for? Browse other questions tagged performance vba excel or ask your own question.

Hot Network Questions

Excel VBA processing getting slower and slower the longer it runs

2 Answers 2

Arrays

Your Answer

Sign up or log in

Post as a guest

Not the answer you're looking for? Browse other questions tagged performance vba excel or ask your own question.

Related

Hot Network Questions