Sluggish Loop Transferring Dictionary Data to Spreadsheet

Question

I've added a timer to my code and the bottleneck comes when I'm looping through 47 rows and inputting data from a dictionary that I previously loaded with values.

Since i use these files for a lot of different things I've set up public variables in order to avoid setting them up for every new code.

So my question is, is there a quicker way to pull data from the dictionary based on criteria in specific cells? The line directly below is repeated 8 times for the 8 different columns being populated with dictionary data, each column takes .20 seconds to complete, so 1.6 seconds per each iteration in the w loop (orderStart to orderEnd).

Cells(w, OF_clearanceColumn1) = stationclearanceData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_clearanceColumn1).Value)

Timer stats:

3.4453125 Open client database, determine which account we're on
3.484375 Find last 4 weks and order range
7.31640625 Adding columns and formating
7.61328125 loop through last 4 weeks, add station clearance and P&L data to dictionary
7.6484375 find range of cumulative, add clearance and P&L for 2019
100.90234375 adding data from dictionary to order file

NEW TIMER STATS, THANKS TO AJD AND MOVING DATA FROM DICTIONARY TO ARRAY TO RANGE.

1.71875 Open client database, determine which account we're on
1.75 Find last 4 weeks and order range
5.3203125 Adding columns and formating
5.6171875 loop through last 4 weeks, add station clearance and P&L data to dictionary
5.6640625 find range of cumulative, add clearance and P&L for 2019
7.6171875 adding data from dictionary to order file

Anyway, below is the code...

Sub Orders_Historicals_autofilterdict()
Dim start As Double
start = Timer
''--------------------------------------
''Static Variables
''--------------------------------------
Call DefinedVariables
Dim orderFile As Variant
Dim orderStart As Long
Dim orderEnd As Long
Dim clientdataFile As Variant
Dim internalFile As Variant
Dim dateStart As Long
Dim stationStart As Long
Dim stationEnd As Long
Dim currentStation As String
Dim currentWeek As String
Dim dictData As New Scripting.Dictionary
Dim stationclearanceData As New Scripting.Dictionary
Dim stationplData As New Scripting.Dictionary
Dim key As Variant
Dim fileOnly As String
Dim networkOnly As String
Dim i As Long
Dim w As Long
Dim t As Long
Dim plTotal As Long
Dim clearTotal As Long
Dim stationHash As String
''--------------------------------------
''Dictionary the Order Abbreviations
''--------------------------------------
 Application.ScreenUpdating = False
 Set orderFile = ActiveWorkbook.ActiveSheet
 Workbooks.Open clientdataLocation
 Set clientdataFile = ActiveWorkbook.Sheets(dan_location) '/ Change sheet when using on different computer
 clientdataFile.Activate
 For i = 1 To Cells(Rows.count, 1).End(xlUp).row
 If dictData.Exists(Cells(i, clientOrder).Value) Then
 Else: dictData.Add Cells(i, clientOrder).Value, i
 End If
 Next
''--------------------------------------
''Determine Account/Network & Open Internal Associated with Order
''--------------------------------------
 orderFile.Activate
 fileOnly = ActiveWorkbook.Name
 fileOnly = Left(fileOnly, InStr(fileOnly, ".") - 1)
 If InStr(fileOnly, 2) > 0 Or InStr(fileOnly, 3) > 0 Then
 fileOnly = Left(fileOnly, Len(fileOnly) - 1)
 End If
 networkOnly = ActiveWorkbook.Name
 networkOnly = Mid(networkOnly, InStr(networkOnly, "IO.") + 3)
 networkOnly = Left(networkOnly, InStr(networkOnly, ".") - 1)
 Workbooks.Open Filename:=clientdataFile.Cells(dictData(fileOnly), clientInternal).Value
 Set internalFile = ActiveWorkbook
 internalFile.Sheets(WT_newWeek).Activate
Debug.Print Timer - start & " Open client database, determine which account we're on"
''--------------------------------------
''Find Last 4 Dates & Column Header for Orders
''--------------------------------------
 For i = 1 To 700
 If Cells(i, 1) = WT_newWeek Then
 dateStart = i
 ElseIf Cells(i, 1) = "Station" Then
 stationStart = i + 1
 Exit For
 End If
 Next
 For i = stationStart To 700
 If Cells(i, 1).Value = Cells(stationStart - 2, 1).Value & " Total" Then
 stationEnd = i - 1
 Exit For
 End If
 Next
 orderFile.Activate
 For i = 1 To 700
 If Cells(i, 1) = "Station" Then
 orderStart = i + 1
 Exit For
 End If
 Next
 For i = orderStart To 700
 If Len(Cells(i, 1)) = 0 And Len(Cells(i - 1, 1)) = 0 And Len(Cells(i - 2, 1)) = 0 Then
 orderEnd = i - 3
 Exit For
 End If
 Next
Debug.Print Timer - start & " Find last 4 weeks and order range"
''--------------------------------------
''Add Dates to Order Header and Formatting
''--------------------------------------
 Cells(orderStart - 1, OF_buyAlgoColumn) = "Algorithm Recommendation"
 Cells(orderStart - 1, OF_totalplColumn) = "Total P&L"
 Cells(orderStart - 1, OF_totalclearanceColumn) = "Total Clearance %"
 Cells(orderStart - 1, OF_clearanceColumn1) = internalFile.Sheets(WT_newWeek).Cells(dateStart, 1)
 Cells(orderStart - 1, OF_clearanceColumn2) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 1, 1)
 Cells(orderStart - 1, OF_clearanceColumn3) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 2, 1)
 Cells(orderStart - 1, OF_clearanceColumn4) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 3, 1)
 Cells(orderStart - 1, OF_plColumn1) = internalFile.Sheets(WT_newWeek).Cells(dateStart, 1)
 Cells(orderStart - 1, OF_plColumn2) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 1, 1)
 Cells(orderStart - 1, OF_plColumn3) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 2, 1)
 Cells(orderStart - 1, OF_plColumn4) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 3, 1)
 Range(Cells(orderStart - 2, OF_clearanceColumn1), Cells(orderStart - 2, OF_clearanceColumn4)) = "Clearance"
 Range(Cells(orderStart - 2, OF_plColumn1), Cells(orderStart - 2, OF_plColumn4)) = "P&L"
 Cells(orderStart - 1, OF_stationColumn).Copy
 Range(Cells(orderStart - 1, OF_buyAlgoColumn), Cells(orderStart - 1, OF_plColumn4)).PasteSpecial xlPasteFormats
 Cells(orderStart, OF_stationColumn).Copy
 Range(Cells(orderStart - 2, OF_clearanceColumn1), Cells(orderStart - 2, OF_plColumn4)).PasteSpecial xlPasteFormats
 Range(Cells(orderStart - 2, OF_buyAlgoColumn), Cells(orderEnd, OF_plColumn4)).HorizontalAlignment = xlCenter
 Cells(orderStart, OF_stationColumn).Copy
 Range(Cells(orderStart, OF_buyAlgoColumn), Cells(orderEnd, OF_plColumn4)).PasteSpecial xlPasteFormats
 Cells(orderStart, OF_totalColumn).Copy
 Range(Cells(orderStart, OF_plColumn1), Cells(orderEnd, OF_plColumn4)).PasteSpecial xlPasteFormats
 Range(Cells(orderStart, OF_totalplColumn), Cells(orderEnd, OF_totalplColumn)).PasteSpecial xlPasteFormats
 Range(Cells(orderStart, OF_totalclearanceColumn), Cells(orderEnd, OF_clearanceColumn4)).NumberFormat = "0%"
 Range(Cells(orderStart - 2, OF_buyAlgoColumn), Cells(orderEnd, OF_plColumn4)).FormatConditions.Delete
 Range(Columns(OF_buyAlgoColumn), Columns(OF_plColumn4)).AutoFit
Debug.Print Timer - start & " Adding columns and formating"
''--------------------------------------
''Add Clearance and P&L by Date to Dictionary
''--------------------------------------
 For i = OF_clearanceColumn1 To OF_clearanceColumn4
 currentWeek = Cells(orderStart - 1, i).Value
 internalFile.Sheets(currentWeek).Activate
 For t = 1 To 700
 If Cells(t, 1) = "Station" Then
 stationStart = t + 1
 Exit For
 End If
 Next
 For t = stationStart To 700
 If Cells(t, 1).Value = Cells(stationStart - 2, 1).Value & " Total" Then
 stationEnd = i - 1
 Exit For
 End If
 If stationclearanceData.Exists(Cells(t, WT_stationColumn).Value & currentWeek) Then
 Else:
 On Error Resume Next
 stationclearanceData.Add Cells(t, WT_stationColumn).Value & currentWeek, Cells(t, WT_mediaactColumn).Value / Cells(t, WT_mediaestColumn).Value
 stationplData.Add Cells(t, WT_stationColumn).Value & currentWeek, Cells(t, WT_profitColumn).Value
 End If
 Next
 orderFile.Activate
 Next
Debug.Print Timer - start & " loop through last 4 weeks, add station clearance and P&L data to dictionary"
''--------------------------------------
''Add Cumulative Clearance and P&L to Dictionary
''--------------------------------------
 internalFile.Sheets("Cumulative").Activate
 For t = 5 To 70000
 If Cells(t, 1) = "" And Cells(t + 1, 1) = "" And Cells(t + 2, 1) = "" Then
 stationEnd = t + 1
 Exit For
 End If
 Next
 For t = 5 To stationEnd
 If Cells(t, CT_yearColumn) = 2019 Then
 If stationclearanceData.Exists(Cells(t, CT_hashColumn).Value) Then
 Else:
 On Error Resume Next
 stationclearanceData.Add Cells(t, CT_hashColumn).Value, Cells(t, CT_clearanceColumn).Value
 stationplData.Add Cells(t, CT_hashColumn).Value, Cells(t, CT_invoiceColumn).Value - Cells(t, CT_actcostColumn).Value
 End If
 End If
 Next
Debug.Print Timer - start & " find range of cumulative, add clearance and P&L for 2019"
 orderFile.Activate
''--------------------------------------
''Loop Through Stations on Order File and Update Based on Dictionary Values
''--------------------------------------
 For w = orderStart To orderEnd
 If Cells(w, OF_stationColumn) <> "" Then
 If Cells(w, OF_stationColumn) <> Cells(w - 1, OF_stationColumn) Then
 stationHash = Cells(w, OF_stationColumn).Value & " " & Cells(w, OF_trafficColumn).Value & " Total"
 On Error Resume Next
 Cells(w, OF_clearanceColumn1) = stationclearanceData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_clearanceColumn1).Value)
 Cells(w, OF_clearanceColumn2) = stationclearanceData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_clearanceColumn2).Value)
 Cells(w, OF_clearanceColumn3) = stationclearanceData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_clearanceColumn3).Value)
 Cells(w, OF_clearanceColumn4) = stationclearanceData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_clearanceColumn4).Value)
 Cells(w, OF_plColumn1) = stationplData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_plColumn1).Value)
 Cells(w, OF_plColumn2) = stationplData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_plColumn2).Value)
 Cells(w, OF_plColumn3) = stationplData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_plColumn3).Value)
 Cells(w, OF_plColumn4) = stationplData(Cells(w, OF_stationColumn).Value & Cells(orderStart - 1, OF_plColumn4).Value)
 Cells(w, OF_totalplColumn) = stationplData(stationHash)
 Cells(w, OF_totalclearanceColumn) = stationclearanceData(stationHash)
 End If
 End If
 Next
Debug.Print Timer - start & " adding data from dictionary to order file"
clientdataFile.Activate
 ActiveWorkbook.Close saveChanges:=False
Application.ScreenUpdating = True
Range(Cells(orderStart - 2, OF_buyAlgoColumn), Cells(orderEnd, OF_plColumn4)).HorizontalAlignment = xlCenter
MsgBox ("Buy Algorithm Complete")
End Sub

Answer 1

Obligatory message: Please ensure you use Option Explicit at the start of every module.

Code readability

The first thing that hits me is a wall of declarations. That and the double spacing makes it hard to review this code. Are all the variables used? I know that there are some variables in there that are not in that wall of declarations.

You are also happy to spread the lines out, but then use "scrunching" techniques such as Else: dictData.Add Cells(i, clientOrder).Value, i

Some of the code here can be broken into logic chunks - either as subroutines or functions. Remember, you can pass parameters to these routines!

DefinedVariables?

I don't know what DefinedVariables does.

Call is deprecated. You just use

DefinedVariables

instead of

Call DefinedVariables

Activethingies

You use the active workbook (explicitly and implicitly), active sheet (explicitly and implicitly) and active cell/range (implicitly) a lot. In reality, you can never be sure what is the active book, sheet or cell, you just don't know if something has changed the focus outside of your macro.

There are some occasions within Excel VBA where immediately grabbing the active object is necessary (e.g. when copying a sheet), but for pretty much all cases you can explicitly qualify the object you are using to prevent the code being hijacked by something that is on screen.

Having said that, activating something while screen updating is off is a null activity.

Object typing

You declare variables as Variant, but then use them for objects

Dim clientdataFile As Variant
Set clientdataFile = ActiveWorkbook.Sheets(dan_location) '/ Change sheet when using on different computer

If you are going to use it for worksheets, then declare it as such!

Dim clientdataFile As Worksheet

Strange use of inbuilt functions

InStr(fileOnly, 2) is not how InStr is supposed to be used. I suspect that this code does not work as intended - have you checked this?

Use Arrays instead of looping through cells

There have been numerous discussions in these hallowed halls about the performance hit of switching between the Excel Model and the VBA model. And every loop that calls a range or a cell performs that switch. The best option is to out the range into an array instead of looping.

The use of a do while loop is neater than an arbitrary For I = loop, the exit conditions are more explicitly stated than a hidden Exit For. Technically correct, but harder to maintain.

Use Excel functionality

Excel has named ranges. This can be exploited to simplify code. You don't have to declare static variables which hold column numbers if you can use the named ranges.

Magic numbers

You have some magic numbers in the code. What is the significance of 700 or 70000 ? How are you going to manage the code if these change - how will you ensure you have got every copy of them?

Also, what happens to stationStart or stationEnd if you go through the loops and do not find the relevant cell? Currently they stay at 0.

what does this look like? Putting most of what I said above into practice gives the following code. This is not tested and I have not moved all the declarations to where they are supposed to be. I have also found a couple left over!

Sub Orders_Historicals_autofilterdict2()
Dim start As Double
start = Timer
''--------------------------------------
''Static Variables
''--------------------------------------
DefinedVariables
Dim currentStation As String
Dim currentWeek As String
Dim stationclearanceData As New Scripting.Dictionary
Dim stationplData As New Scripting.Dictionary
Dim key As Variant
Dim i As Long
Dim w As Long
Dim plTotal As Long
Dim clearTotal As Long
Dim stationHash As String
''--------------------------------------
''Dictionary the Order Abbreviations
''--------------------------------------
 Application.ScreenUpdating = False
Dim orderFile As Worksheet ' notVariant
Dim clientdataFile As Worksheet 'Variant
Dim clientdataBook As Workbook ' I added this
Dim dictData As New Scripting.Dictionary
 Set orderFile = ActiveWorkbook.ActiveSheet ' consider putting that orderBook variable in, because this gets used a few times later.
 Set clientdataBook = Workbooks.Open(clientdataLocation) 'clientdataLocation is undeclared? What happens if this is null?
 Set clientdataFile = clientdataBook.Sheets(dan_location) '/ Change sheet when using on different computer
 With clientdataFile ' not activate! Now the following code is fully qualified.
 For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
 If dictData.Exists(.Cells(i, clientOrder).Value) Then ' This could be "If Not dictData etc."
 Else
 dictData.Add .Cells(i, clientOrder).Value, i
 End If
 Next
 End With
''--------------------------------------
''Determine Account/Network & Open Internal Associated with Order
''--------------------------------------
Dim fileOnly As String
Dim networkOnly As String
Dim internalBook As Workbook ' I added this
 fileOnly = orderFile.Parent.Name ' no need to activate
 fileOnly = Left(fileOnly, InStr(fileOnly, ".") - 1)
 If InStr(fileOnly, 2) > 0 Or InStr(fileOnly, 3) > 0 Then '' Does this actually work?
 fileOnly = Left(fileOnly, Len(fileOnly) - 1)
 End If
 networkOnly = orderFile.Parent.Name ' at this point, you have already lost track of what is supposed to be active.
 networkOnly = Mid(networkOnly, InStr(networkOnly, "IO.") + 3)
 networkOnly = Left(networkOnly, InStr(networkOnly, ".") - 1)
Dim internalFile As Workbook
 Set internalFile = Workbooks.Open(Filename:=clientdataFile.Cells(dictData(fileOnly), clientInternal).Value)
Debug.Print Timer - start & " Open client database, determine which account we're on"
''--------------------------------------
''Find Last 4 Dates & Column Header for Orders
''--------------------------------------
Dim dateStart As Long
Dim stationStart As Long
Dim stationEnd As Long
Dim orderStart As Long
Dim orderEnd As Long
Dim findStationArray As Variant ' I added the next 4
Dim startFound As Boolean
Dim endFound As Boolean
Dim stationStartValue As String ' assumption here
 With internalFile.Sheets(WT_newWeek) ' no need to Activate!
 findStationArray = .Range("A1:A700").Value
 i = LBound(findStationArray, 1)
 While i <= UBound(findStationArray, 1) Or Not startFound
 Select Case .Cells(i, 1).Value
 Case WT_newWeek
 dateStart = i
 Case "Station"
 If Not startFound Then
 stationStart = i + 1
 startFound = True
 End If
 End Select
 i = i + 1
 Wend
 stationStartValue = .Cells(stationStart - 2, 1).Value & " Total" ' do this only once, not 700 times
 While i <= UBound(findStationArray, 1) Or Not endFound
 endFound = (.Cells(i, 1).Value = stationStartValue)
 If endFound Then stationEnd = i - 1
 i = i + 1
 Wend
 End With
 With orderFile ' again - do not .Activate
 findStationArray = .Range("A1:A700").Value
 i = LBound(findStationArray, 1)
 While i <= UBound(findStationArray, 1) Or Not startFound
 startFound = (.Cells(i, 1).Value = "Station")
 If startFound Then orderStart = i + 1
 i = i + 1
 Wend
 While i <= UBound(findStationArray, 1) Or Not endFound
 endFound = (Len(.Cells(i, 1)) = 0 And Len(.Cells(i - 1, 1)) = 0 And Len(.Cells(i - 2, 1)) = 0)
 If endFound Then orderEnd = i - 3
 i = i + 1
 Wend
 End With
Debug.Print Timer - start & " Find last 4 weeks and order range"
''--------------------------------------
''Add Dates to Order Header and Formatting
''--------------------------------------
 With orderFile ' assumption here - have we lost track of what is active yet?
 .Cells(orderStart - 1, OF_buyAlgoColumn) = "Algorithm Recommendation"
 .Cells(orderStart - 1, OF_totalplColumn) = "Total P&L"
 .Cells(orderStart - 1, OF_totalclearanceColumn) = "Total Clearance %"
 .Cells(orderStart - 1, OF_clearanceColumn1) = internalFile.Sheets(WT_newWeek).Cells(dateStart, 1)
 .Cells(orderStart - 1, OF_clearanceColumn2) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 1, 1)
 .Cells(orderStart - 1, OF_clearanceColumn3) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 2, 1)
 .Cells(orderStart - 1, OF_clearanceColumn4) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 3, 1)
 .Cells(orderStart - 1, OF_plColumn1) = internalFile.Sheets(WT_newWeek).Cells(dateStart, 1)
 .Cells(orderStart - 1, OF_plColumn2) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 1, 1)
 .Cells(orderStart - 1, OF_plColumn3) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 2, 1)
 .Cells(orderStart - 1, OF_plColumn4) = internalFile.Sheets(WT_newWeek).Cells(dateStart - 3, 1)
 .Range(.Cells(orderStart - 2, OF_clearanceColumn1), .Cells(orderStart - 2, OF_clearanceColumn4)) = "Clearance"
 .Range(.Cells(orderStart - 2, OF_plColumn1), .Cells(orderStart - 2, OF_plColumn4)) = "P&L"
 .Cells(orderStart - 1, OF_stationColumn).Copy
 .Range(.Cells(orderStart - 1, OF_buyAlgoColumn), .Cells(orderStart - 1, OF_plColumn4)).PasteSpecial xlPasteFormats
 .Cells(orderStart, OF_stationColumn).Copy
 .Range(.Cells(orderStart - 2, OF_clearanceColumn1), .Cells(orderStart - 2, OF_plColumn4)).PasteSpecial xlPasteFormats
 .Range(.Cells(orderStart - 2, OF_buyAlgoColumn), .Cells(orderEnd, OF_plColumn4)).HorizontalAlignment = xlCenter
 .Cells(orderStart, OF_stationColumn).Copy
 .Range(.Cells(orderStart, OF_buyAlgoColumn), .Cells(orderEnd, OF_plColumn4)).PasteSpecial xlPasteFormats
 .Cells(orderStart, OF_totalColumn).Copy
 .Range(.Cells(orderStart, OF_plColumn1), .Cells(orderEnd, OF_plColumn4)).PasteSpecial xlPasteFormats
 .Range(.Cells(orderStart, OF_totalplColumn), .Cells(orderEnd, OF_totalplColumn)).PasteSpecial xlPasteFormats
 .Range(.Cells(orderStart, OF_totalclearanceColumn), .Cells(orderEnd, OF_clearanceColumn4)).NumberFormat = "0%"
 .Range(.Cells(orderStart - 2, OF_buyAlgoColumn), .Cells(orderEnd, OF_plColumn4)).FormatConditions.Delete
 .Range(.Columns(OF_buyAlgoColumn), .Columns(OF_plColumn4)).AutoFit
 End With
Debug.Print Timer - start & " Adding columns and formating"
''--------------------------------------
''Add Clearance and P&L by Date to Dictionary
''--------------------------------------
Dim t As Long
 For i = OF_clearanceColumn1 To OF_clearanceColumn4
 currentWeek = orderFile.Cells(orderStart - 1, i).Value
 With internalFile.Sheets(currentWeek)
 findStationArray = .Range("A1:A700").Value
 t = LBound(findStationArray, 1)
 While t <= UBound(findStationArray, 1) Or Not startFound
 startFound = (.Cells(t, 1).Value = "Station")
 If startFound Then stationStart = t + 1
 t = t + 1
 Wend
 stationStartValue = .Cells(stationStart - 2, 1).Value & " Total" ' do this only once, not 700 times
 While t <= UBound(findStationArray, 1) Or Not endFound
 endFound = (.Cells(t, 1).Value = stationStartValue)
 If endFound Then
 stationEnd = i - 1 ' is this meant to be "i" or "t" ?
 Else
 If stationclearanceData.Exists(Cells(t, WT_stationColumn).Value & currentWeek) Then
 Else
 On Error Resume Next ' I assume you want to fail silently. Otherwise this is dangerous
 stationclearanceData.Add Cells(t, WT_stationColumn).Value & currentWeek, Cells(t, WT_mediaactColumn).Value / Cells(t, WT_mediaestColumn).Value
 stationplData.Add Cells(t, WT_stationColumn).Value & currentWeek, Cells(t, WT_profitColumn).Value
 On Error GoTo 0 ' stop the error hiding - otherwise you will not pick up any errors later in the code
 End If
 End If
 i = i + 1
 Wend
 End With
 Next i
Debug.Print Timer - start & " loop through last 4 weeks, add station clearance and P&L data to dictionary"
''--------------------------------------
''Add Cumulative Clearance and P&L to Dictionary
''--------------------------------------
Dim cumulativeSheet As Worksheet
 With internalFile.Sheets("Cumulative") ' again, no need to .Activate
 findStationArray = .Range("A5:A70000").Value
 t = LBound(findStationArray, 1)
 While t <= UBound(findStationArray, 1) Or Not endFound
 endFound = (.Cells(t, 1) = "" And .Cells(t + 1, 1) = "" And .Cells(t + 2, 1) = "")
 ' If endFound Then stationEnd = t + 1 ' this is superfluous, because the loop will exit with t+1 anyway. But good to have here for future readability and maintenance.
 t = t + 1
 Wend
 For t = 5 To stationEnd
 If Cells(t, CT_yearColumn) = 2019 Then
 If stationclearanceData.Exists(Cells(t, CT_hashColumn).Value) Then
 Else
 On Error Resume Next
 stationclearanceData.Add Cells(t, CT_hashColumn).Value, Cells(t, CT_clearanceColumn).Value
 stationplData.Add Cells(t, CT_hashColumn).Value, Cells(t, CT_invoiceColumn).Value - Cells(t, CT_actcostColumn).Value
 On Error GoTo 0 ' stop the error hiding - otherwise you will not pick up any errors later in the code
 End If
 End If
 Next
Debug.Print Timer - start & " find range of cumulative, add clearance and P&L for 2019"
''--------------------------------------
''Loop Through Stations on Order File and Update Based on Dictionary Values
''--------------------------------------
' **** The changes here are for better performance.
Dim stationValues As Variant
Dim trafficValues As Variant
Dim totalPLValues As Variant
Dim totalClearanceValues As Variant
Dim clearance1Values As Variant ' if these are contiguous columns then this could be handled as a two dimensional array.
Dim clearance2Values As Variant
Dim clearance3Values As Variant
Dim clearance4Values As Variant
Dim pl1Values As Variant ' Ditto
Dim pl2Values As Variant
Dim pl3Values As Variant
Dim pl4Values As Variant
Dim clearanceValue1 As String
Dim clearanceValue2 As String
Dim clearanceValue3 As String
Dim clearanceValue4 As String
Dim plValue1 As String
Dim plValue2 As String
Dim plValue3 As String
Dim plValue4 As String
 With orderFile '.Activate
 stationValues = .Range(.Cells(orderStart - 1, OF_stationColumn), .Cells(orderEnd, OF_stationColumn)).Value ' use arrays instead of calling excel ranges
 trafficValues = .Range(.Cells(orderStart - 1, OF_trafficColumn), .Cells(orderEnd, OF_trafficColumn)).Value ' use arrays instead of calling excel ranges
 totalPLValues = .Range(.Cells(orderStart - 1, OF_totalplColumn), .Cells(orderEnd, OF_totalplColumn)).Value
 totalClearanceValues = .Range(.Cells(orderStart - 1, OF_totalclearanceColumn), .Cells(orderEnd, OF_totalclearanceColumn)).Value
 clearance1Values = .Range(.Cells(orderStart - 1, OF_clearanceColumn1), .Cells(orderEnd, OF_clearanceColumn1)).Value
 clearance2Values = .Range(.Cells(orderStart - 1, OF_clearanceColumn2), .Cells(orderEnd, OF_clearanceColumn2)).Value
 clearance3Values = .Range(.Cells(orderStart - 1, OF_clearanceColumn3), .Cells(orderEnd, OF_clearanceColumn3)).Value
 clearance4Values = .Range(.Cells(orderStart - 1, OF_clearanceColumn4), .Cells(orderEnd, OF_clearanceColumn4)).Value
 pl1Values = .Range(.Cells(orderStart - 1, OF_plColumn1), .Cells(orderEnd, OF_plColumn1)).Value
 pl2Values = .Range(.Cells(orderStart - 1, OF_plColumn2), .Cells(orderEnd, OF_plColumn2)).Value
 pl3Values = .Range(.Cells(orderStart - 1, OF_plColumn3), .Cells(orderEnd, OF_plColumn3)).Value
 pl4Values = .Range(.Cells(orderStart - 1, OF_plColumn4), .Cells(orderEnd, OF_plColumn4)).Value
 clearanceValue1 = .Cells(orderStart - 1, OF_clearanceColumn1).Value ' evaluate these only once, instead of every time in the loop
 clearanceValue2 = .Cells(orderStart - 1, OF_clearanceColumn2).Value
 clearanceValue3 = .Cells(orderStart - 1, OF_clearanceColumn3).Value
 clearanceValue4 = .Cells(orderStart - 1, OF_clearanceColumn4).Value
 plValue1 = .Cells(orderStart - 1, OF_plColumn1).Value
 plValue2 = .Cells(orderStart - 1, OF_plColumn2).Value
 plValue3 = .Cells(orderStart - 1, OF_plColumn3).Value
 plValue4 = .Cells(orderStart - 1, OF_plColumn4).Value
 For w = LBound(stationValues) + 1 To UBound(stationValues) 'orderStart To orderEnd
 If stationValues(w, 1) <> "" Then
 If stationValues(w, 1) <> stationValues(w - 1, 1) Then
 stationHash = stationValues(w, 1) & " " & stationValues(w, 1) & " Total"
 ' On Error Resume Next ' don't hide errors - what is the issue here?
 clearance1Values(w, 1) = stationclearanceData(stationValues(w, 1) & clearanceValue1)
 clearance2Values(w, 1) = stationclearanceData(stationValues(w, 1) & clearanceValue2)
 clearance3Values(w, 1) = stationclearanceData(stationValues(w, 1) & clearanceValue3)
 clearance4Values(w, 1) = stationclearanceData(stationValues(w, 1) & clearanceValue4)
 pl1Values(w, 1) = stationclearanceData(stationValues(w, 1) & plValue1)
 pl1Values(w, 2) = stationclearanceData(stationValues(w, 1) & plValue2)
 pl1Values(w, 3) = stationclearanceData(stationValues(w, 1) & plValue3)
 pl1Values(w, 4) = stationclearanceData(stationValues(w, 1) & plValue4)
 totalPLValues(w, 1) = stationplData(stationHash)
 totalClearanceValues(w, 1) = stationclearanceData(stationHash)
 End If
 End If
 Next
 ' return the changed arrays to the ranges.
 .Range(.Cells(orderStart - 1, OF_totalplColumn), .Cells(orderEnd, OF_totalplColumn)).Value = totalPLValues
 .Range(.Cells(orderStart - 1, OF_totalclearanceColumn), .Cells(orderEnd, OF_totalclearanceColumn)).Value = totalClearanceValues
 .Range(.Cells(orderStart - 1, OF_clearanceColumn1), .Cells(orderEnd, OF_clearanceColumn1)).Value = clearance1Values
 .Range(.Cells(orderStart - 1, OF_clearanceColumn2), .Cells(orderEnd, OF_clearanceColumn2)).Value = clearance2Values
 .Range(.Cells(orderStart - 1, OF_clearanceColumn3), .Cells(orderEnd, OF_clearanceColumn3)).Value = clearance3Values
 .Range(.Cells(orderStart - 1, OF_clearanceColumn4), .Cells(orderEnd, OF_clearanceColumn4)).Value = clearance4Values
 .Range(.Cells(orderStart - 1, OF_plColumn1), .Cells(orderEnd, OF_plColumn1)).Value = pl1Values
 .Range(.Cells(orderStart - 1, OF_plColumn2), .Cells(orderEnd, OF_plColumn2)).Value = pl2Values
 .Range(.Cells(orderStart - 1, OF_plColumn3), .Cells(orderEnd, OF_plColumn3)).Value = pl3Values
 .Range(.Cells(orderStart - 1, OF_plColumn4), .Cells(orderEnd, OF_plColumn4)).Value = pl4Values
 End With
Debug.Print Timer - start & " adding data from dictionary to order file"
 clientdataBook.Close saveChanges:=False
 Application.ScreenUpdating = True
 ' lost track of what is supposed to be active yet?
 orderFile.Range(Cells(orderStart - 2, OF_buyAlgoColumn), Cells(orderEnd, OF_plColumn4)).HorizontalAlignment = xlCenter
 MsgBox ("Buy Algorithm Complete")
End Sub

• Dan: Very good information and I appreciate the response. Doesn't look like I can answer all your questions in this little comment box. But a few comments you made helped me like declaring as worksheet instead of variant. I didn't know what to do with it which is why I did variant. InStr I think it supposed to be "2" not just 2 and it will rarely pop but it would mess with opening the correct data. The magic numbers are just max numbers, nothing special to them. Stationstart/end will find what they are looking for because it's the same template used for each file.
• Dan: I put your code in and I get an error. Method or data member not found and it stops on fileOnly = orderFile.Workbook.Name ' no need to activate
• AJD: @Dan: Yes, my error and did not pick it up due to not testing. The change required is fileOnly = orderFile.Parent.Name, and also a few lines down networkOnly = orderFile.Workbook.Name. Because Parent is a generic object, the Name property will not come up in Intellisense. In this case, Parent is implicitly converted to a Workbook object (because orderFile is a WorkSheet) which does have the Name property/data member.
• AJD: I didn't pick it up in my review, but you don't use the variable networkOnly in your logic, so those few lines of code aren't required.
• Dan: Correct, I had a plan for networkOnly but then didn't use it so I can probably delete it. Let me go through your change and see how it runs. Give me a few minutes, thank you for your help.