Improve / optimize Excel macro to search for text phrases within a folder of text reports - vba

Question

Using Microsoft Excel 2010, this macro searches for a list of phrases within a folder of text reports. For each phrase, it searches all of the reports and lists each report that contains the phrase.
I found some better macros to do each part of the macro - such as enumerating a directory, or finding a phrase within a text file - although I had a really hard time putting them together successfully. Despite it not being perfect, it may be helpful for others with the same problem, and I hope for some feedback on how to improve and optimize the macro.
Basic overview:
Column A: list of full path to text reports (for instance, "C:\path\to\report.txt")
Column B: name of report (such as "report.txt")
Column C: list of phrases to search for
Columns D+: output showing each report that contains the phrase (column C)
Areas for improvement:
Make the macro run faster! (This took over an hour for 360 reports and 1100 phrases)
Select the reports and report folder from a pop-up or other function (currently entered into the spreadsheet using another macro)
Filter reports by file name (for instance, only check reports with a word or phrase in the file name)
Filter reports by file extension (for instance, only check .txt files and not .xlsx files)
Detect the number of reports and phrases (currently this is hard coded)
Other suggestions / areas for improvement
Code:
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim findCount As Integer
Dim i As Integer
Dim j As Integer
For i = 2 To 1109
searchTerm = Range("C" & i).Value
findCount = 0
For j = 2 To 367
fn = Range("A" & j).Value
fileName = Range("B" & j).Value
With CreateObject("Scripting.FileSystemObject").OpenTextFile(fn)
Do While Not .AtEndOfStream
lineString = .ReadLine
If InStr(1, lineString, searchTerm, vbTextCompare) Then
findCount = findCount + 1
Cells(i, 3 + findCount) = fileName
GoTo EarlyExit
End If
Loop
EarlyExit:
.Close
End With
Next j
Next i
End Sub

Answer 1

As #Makah pointed out, you're opening a lot of files, which is slow. To fix this, change the order of the loops (see the code below). This will switch from 407,003 file opens to 367. Along the same lines, lets create the FileSystemObject once, instead of once per file open.
Also, VBA is surprisingly slow at reading/writing data from/to Excel. We can deal with this by loading largw blocks of data into VBA all at once with code like
dim data as Variant
data = Range("A1:Z16000").value
And then writing it back to Excel in a large block like
Range("A1:Z16000").value = data
I have also added in code to dynamically check the dimension of your data. We assume that the data starts in cell A2, and if A3 is empty, we use the single cell A2. Otherwise, we use .End(xlDown) to move down to just above the first empty cell in column A. This is the equivalent of pressing ctrl+shift+down.
Note: the following code has not been tested. Also, it requires a reference to "Microsoft Scripting Runtime" for the FileSystemObjects.
Sub findStringMacro()
Dim fn As String
Dim lineString As String
Dim fileName As String
Dim searchTerm As String
Dim i As Integer, j As Integer
Dim FSO As Scripting.FileSystemObject
Dim txtStr As Scripting.TextStream
Dim file_rng As Range, file_cell As Range
Dim output As Variant
Dim output_index() As Integer
Set FSO = New Scripting.FileSystemObject
Set file_rng = Range("A2")
If IsEmpty(file_rng) Then Exit Sub
If Not IsEmpty(file_rng.Offset(1, 0)) Then
Set file_rng = Range(file_rng, file_rng.End(xlDown))
End If
If IsEmpty(Range("C2")) Then Exit Sub
If IsEmpty(Range("C3")) Then
output = Range("C2")
Else
output = Range(Range("C2"), Range("C2").End(xlDown))
End If
ReDim Preserve output(1 To UBound(output, 1), 1 To file_rng.Rows.Count + 1)
ReDim output_index(1 To UBound(output, 1))
For i = 1 To UBound(output, 1)
output_index(i) = 2
Next i
For Each file_cell In file_rng
fn = file_cell.Value 'Range("A" & j)
fileName = file_cell.Offset(0, 1).Value 'Range("B" & j)
Set txtStr = FSO.OpenTextFile(fn)
Do While Not txtStr.AtEndOfStream
lineString = txtStr.ReadLine
For i = 1 To UBound(output, 1)
searchTerm = output(i, 1) 'Range("C" & i)
If InStr(1, lineString, searchTerm, vbTextCompare) Then
If output(i, output_index(i)) <> fileName Then
output_index(i) = output_index(i) + 1
output(i, output_index(i)) = fileName
End If
End If
Next i
Loop
txtStr.Close
Next file_cell
Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output
Set txtStr = Nothing
Set FSO = Nothing
Set file_cell = Nothing
Set file_rng = Nothing
End Sub