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
Exp
worksheet. You mention that you have 77 worksheets in the workbook -- how is this code supposed to run over the other 76? \$\endgroup\$