Excel VBA processing getting slower and slower the longer it runs

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.

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
• Cross-posted on Stack Overflow – Mast Apr 11 '18 at 16:35
• 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

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:

1. 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

2. 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)

3. 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

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