Code slow down as report grows - vba

Question

I have been running this code in my day to day work to keep on top of my orders and shipping, the code opens a spreadsheet in a specified location and returns the following, invoice number, company name, shipping date and total order value and puts them into one main spreadsheet.
I started using it last year and it used to take just under 3 minutes to run through about 400-500 spread sheets to collect the data. now I have a similar amount of data to run through this year but the report takes hours!!
I haven't changed my report and the data is the same data from the same template just in a different folder but in the same location on the same drive under the same parent folder.
I don't think it s the change of location that has slowed it down.
I have included a copy of my code below with notes under most of the code to explain the function of each line, can anyone see any problems with the code or recommend any improvements?
Sub Invoice_Records()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim FileExt As String
Dim CellValue As Range
Dim Text As String
Dim Text2 As String
Dim Text3 As String
Dim Total As Range
Dim filecountB As String
Dim i As String
Dim ws As Worksheet
Dim Invoice_Count As Integer
Set ws = Worksheets("Admin2")
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns(2).EntireColumn.Clear
ws.Columns(3).EntireColumn.Clear
ws.Columns(4).EntireColumn.Clear
ws.Columns(5).EntireColumn.Clear
ws.Columns(6).EntireColumn.Clear
ws.Columns(7).EntireColumn.Clear
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
filecountB = objFolder.Files.Count
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
ws.Cells(i + 1, 2) = objFile.Name
'print file path
ws.Cells(i + 1, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Path
'Get the file extension
FileExt = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, "."))
'Paste file extension in column D
ws.Cells(i + 1, 4) = FileExt
If FileExt = "xlsm" Then
'This line stops the excel documents opening on your screen they just open in the background meaning your screen does not flicker
Application.ScreenUpdating = False
Application.StatusBar = True
Application.StatusBar = "Currently processing item " + i + " out of " + filecountB
'This opens the documents
Workbooks.Open Filename:=objFile.Path
'Tells VBA what you are looking for
Text = "Total Invoice Value"
'Find text, defined in line above
Set Match = ActiveSheet.Cells.Find(Text)
'Get the value of the cell next to cell found above
findoffset = Match.Offset(, 1).Value
'Paste this value in to column F
ws.Cells(i + 1, 6) = findoffset
'Tells VBA what else to look for
Text2 = "Order No:"
'Find Text2, defined in line above
Set Index = ActiveSheet.Cells.Find(Text2)
'If "Order No:" cant be found then do below if it is found skip to ELSE
If Index Is Nothing Then
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
Else
'Paste the "Order No:" in column G
ws.Cells(i + 1, 7) = Index
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
End If
Else
'If file extension is anything other than XLSM then leave the date blank
ws.Cells(i + 1, 5) = ""
'Go onto the next file
i = i + 1
End If
Next objFile
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
Application.StatusBar = False
Call FindingLastRow
End Sub
Sub FindingLastRow()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Set ws = Worksheets("Admin2")
'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "A")
'returns the cell A1048576, ie. last cell in column A, and the code starts from this cell moving upwards;
'the code is bascially executing Range("A1048576").End(xlUp), and Range("A1048576").End(xlUp).Row finally returns the last row number.
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
ws.Range("Row_Number").Value = lastRow
End Sub

Answer 1

Alright, so I changed a few things and removed some unnecessary code. Here is my "changelog":
Commented out call to FindingLastRow as it currently does nothing
Moved the 'Dims' around so that they are easier to read
Removed unused variables
Added variables for the temporary workbooks
I did this to avoid using ActiveSheet which will slow code down
NOTE: The line that sets wsTemp might not work correctly, let me know if it fails
Grouped the columns.clear calls you made
Changed starting value of i to 2 for simplicity
Added range variables to catch the Range.Find("..") results
Moved Application.ScreenUpdating call outside of loop
No reason to have it toggle so frequently inside of the loop itself
Added toggle to .Calculation and .EnableEvents to potentially speed program up further
They act similarly to .ScreenUpdating by suppressing excel and speed up by focusing on only certain operations
Removed the .select for the hyperlinks
Like calling Activesheet, calling .select will also slow code down
String concatenation for StatusBar uses & instead of +
Changed around how the if statements were used to clear out duplicate code
A couple times you were repeating code in the ifs when you can just do it right after them
Re-ordered the value pasting to match the columns theyre pasted in (ie C,D,E,F,G )
When calling cells using .cells(r,c) you can actually just use the column string, so I did that for simplicity
NOTE: your comments said that 'Date' would go in column F but your actual code put it in column E, so I chose to use E
Started using .value2 and .value when accessing/pasting text into cells
NOTE: added offset to the "order no" to match your other searches (it looked like an oversight)
I think that's it???
With all that in mind, here is the result. Hopefully it scales properly with your folder now :)
Sub Invoice_Records()
Dim ws As Worksheet
Set ws = Worksheets("Admin2")
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
'Create an instance of the FileSystemObject
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Dim objFolder As Object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
Dim objFile As Object
Dim i As Long
i = 2
Dim FileExtension As String
Dim filecountB As String
filecountB = objFolder.Files.count
Dim searchInvValue As Range
Dim searchOrderNum As Range
Dim searchDate As Range
'Toggling screen updating prevents screen flicker and speeds up operations
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.StatusBar = True
End With
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns("B:G").EntireColumn.Clear
'Loops through each file in the directory
For Each objFile In objFolder.Files
'Update status bar to show progress
Application.StatusBar = "Currently processing item " & (i - 1) & " out of " & filecountB
'Paste file name
ws.Cells(i, "B").Value2 = objFile.Name
'Paste file path and add a hyperlink to it
ws.Hyperlinks.Add Anchor:=ws.Cells(i, "C"), Address:=objFile.path, TextToDisplay:=objFile.path
'Get the file extension
FileExtension = UCase$(Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")))
'Paste file extension
ws.Cells(i, "D").Value2 = FileExtension
'Only do operations on files with the extension "xlsm", otherwise skip
If FileExtension = "xlsm" Then
'This opens the current "objFile" document
Set wbTemp = Workbooks.Open(Filename:=objFile.path)
Set wsTemp = wbTemp.Sheets(1)
'Find and paste "Date:"
Set searchDate = wsTemp.Cells.Find("Date:")
ws.Cells(i, "E").value = searchDate.Offset(, 1).value
'Find and paste "Total Invoice Value"
Set searchInvValue = wsTemp.Cells.Find("Total Invoice Value")
ws.Cells(i, "F").Value2 = searchInvValue.Offset(, 1).Value2
'Find "Order No:" and paste if not blank
Set searchOrderNum = wsTemp.Cells.Find("Order No:")
If Not searchOrderNum Is Nothing Then ws.Cells(i, "G").Value2 = searchOrderNum.Offset(, 1).Value2
'Close the current "objFile" workbook
wbTemp.Close
End If
'Go onto the next file
i = i + 1
Next objFile
'Turn screen updating back on so that you can see the values being updated
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.StatusBar = False
End With
'Call FindingLastRow 'this does not currently seem necessary
End Sub