Making excel macro for file scanning more stable - vba

Question

I was curious if anybody could provide suggestions on how I can make an excel macro more stable.
The macro prompts the user for a path to a folder containing files to scan. The macro then iterates for every file in this folder.
It opens the excel file, scans Column D for the word fail, then copies that row of data to the data sheet in the excel file where this macro is programmed.
For the most part the macro runs perfectly but sometimes I get run time errors or 'excel has stopped working' errors. I can scan through 5000+ files at a time and the macro takes a while to run.
Any suggestions would be appreciated. Thanks!
Sub findFail()
Dim pathInput As String 'path to file
Dim path As String 'path to file after being validated
Dim fileNames As String 'path to test file
Dim book As Workbook 'file being tested
Dim sheet As Worksheet 'sheet writting data to
Dim sh As Worksheet 'worksheet being tested
Dim dataBook As Workbook 'where data is recorded
Dim row As Long 'row to start writting data in
Dim numTests As Long 'number of files tested
Dim j As Long 'counter for number of files tested
Dim i As Long 'row currently being tested
Dim lastRow As Long 'last row used
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Application.ScreenUpdating = False
j = 0
i = 1
row = 2
Set dataBook = ActiveWorkbook
Set sheet = Worksheets("Data")
sheet.Range("A2:i1000").Clear
startTime = Timer
'-----Prompt for Path-----
pathInput = InputBox(Prompt:="Enter path to files. It must have a \ after folder name.", _
Title:="Single Report", _
Default:="C:\Folder\")
If pathInput = "C:\Folder\" Or pathInput = vbNullString Then 'check to make sure path was inputed
MsgBox ("Please enter a valid file path and try again.")
Exit Sub
Else
path = pathInput 'path = "C:\Temp\212458481\" ' Path for file location
fileNames = Dir(path & "*.xls") 'for xl2007 & "*.xls?" on windows
'-----begin testing-----
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
lastRow = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).row
If sh.Cells(lastRow, 2).Value - sh.Cells(1, 2).Value >= 0.08333333 Then
Do While sh.Range("D" & i).Value <> "" 'loop untile there are no rows left to test
If sh.Range("D" & i).Value = "Fail" Then 'record values if test result is false
sheet.Range("A" & row).Value = book.Name
sheet.Range("B" & row).Value = Format(sh.Range("B" & i).Value - sh.Range("B1").Value, "h:mm:ss")
sheet.Range("C" & row).Value = sh.Range("A" & i).Value
sheet.Range("D" & row).Value = Format(sh.Range("B" & i).Value, "h:mm:ss")
sheet.Range("E" & row).Value = sh.Range("C" & i).Value
sheet.Range("F" & row).Value = sh.Range("D" & i).Value
sheet.Range("G" & row).Value = sh.Range("E" & i).Value
sheet.Range("H" & row).Value = sh.Range("F" & i).Value
sheet.Range("I" & row).Value = sh.Range("G" & i).Value
row = row + 1
Exit Do
End If
i = i + 1
Loop
j = j + 1
dataBook.Sheets("Summary").Cells(2, 1).Value = j
End If
book.Close SaveChanges:=False
fileNames = Dir()
i = 1
Loop
numTests = j
Worksheets("Summary").Cells(2, "A").Value = numTests
minsElapsed = Timer - startTime
Worksheets("Summary").Cells(2, "B").Value = Format(minsElapsed / 86400, "hh:mm:ss")
End If
End Sub

Answer 1

Without the same dataset as you we, can not definitively supply an answer but I can recommend the below which is related to the error you are seeing.
Try freeing/destroying the references to book and sh.
You have a loop that sets them:-
Do While fileNames <> "" 'Loop until filename is blank
Set book = Workbooks.Open(path & fileNames)
Set sh = book.Worksheets(1)
However the end of the loop does not clear them, ideally it should look as below:-
Set sh = Nothing
Set book = Nothing
Loop
This is a better way to handle resources and should improve memory usage.
As a poor example, without it your code is saying, sh equals this, now it equals this instead, now it equals this instead, now it equals this instead, etc...
You end up with the previous reference that was subsequently overwritten being a sort of orphaned object that is holding some space in memory.

Answer 2

Depending on your case, you may use the following to make it faster -by turning off excel processes that you don't really need at the time of your macro execution-
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.StatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
End Sub
In your sub
Dim startTime As Double 'time when program started
Dim minsElapsed As Double 'time it took program to end
Call ExcelBusy
...
As a comment, you never set back screenupdating to true in your sub, that may lead to strange behavior in excel, you should turn everything to default after you are done with your stuff.
OT: Some processes can't be optimized any further -sometimes-, by what you are saying -scanning over 5k files?- surely it's going to take a time, you need to work in how to communicate the user that is going to take a while instead -perhaps an application status bar message or a user form showing process?-.