Search through each file in a directory, list number of instances of searched string

Question

I am trying to open each file listed in Sheet2 Column A, search for a string of text located in Sheet3 Cell B1, list the number of instances this string appears in each particular file in Sheet3, and then close the file.

My code works at the moment is very slow. I have tens of thousands of files that need searching, so speed is just as important as performance.

Is there a way to complete this task more efficiently than what I am already doing?

Sub FindMe()

Dim fle As Range
Dim i As Long
Dim k As Long
Dim line As Long
Dim strline As String
Dim strsearch As String
Dim loc As Range
Dim sht As Worksheet
Dim lngPos As Long
Dim lngCount As Long
Dim wdApp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim osld As Object
Dim oshp As Object
Dim pptApp As Object
Dim pptdoc As Object

Sheet3.Range("A4:B999999").ClearContents
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not IsEmpty(Sheet3.Range("B1").Value) Then
    strsearch = Sheet3.Range("B1").Value
    i = 0
    k = 4
    lngCount = 0
    For Each fle In Sheet2.Range("A:A")
        If InStr(1, fle.Value, ".txt") > 0 Then     '.txt extension
            Open fle.Value For Input As #1
            Do While Not EOF(1)
                Line Input #1, strline
                lngPos = 1
                Do
                    lngPos = InStr(lngPos, strline, strsearch, vbTextCompare)
                    If lngPos > 0 Then
                        lngCount = lngCount + 1
                        lngPos = lngPos + Len(strsearch)
                    End If
                Loop Until lngPos = 0
            Loop
            If lngCount <> 0 Then
                Sheet3.Cells(k, 1).Value = lngCount
                Sheet3.Cells(k, 2).Value = fle.Value
                k = k + 1
                lngCount = 0
            End If
            Close #1

        ElseIf InStr(1, fle.Value, ".xls") > 0 Or InStr(1, fle.Value, ".csv") Then     '.xls, .xlsx, .xlsm, .csv extentions
            Workbooks.Open Filename:=fle.Value, ReadOnly:=True, UpdateLinks:=False
            For Each sht In ActiveWorkbook.Worksheets
                With sht
                    Set loc = .Cells.Find(What:=strsearch)
                    If Not loc Is Nothing Then
                        FirstAddress = loc.Address
                        Do
                            i = i + 1
                            Set loc = .Cells.FindNext(loc)
                        Loop While Not loc Is Nothing And loc.Address <> FirstAddress
                    End If
                End With
            Next sht
            ActiveWorkbook.Close False
            If i <> 0 Then
                Sheet3.Cells(k, 1).Value = i
                Sheet3.Cells(k, 2).Value = fle.Value
                k = k + 1
                i = 0
            End If

        ElseIf InStr(1, fle.Value, ".doc") > 0 Or InStr(1, fle.Value, ".pdf") > 0 Then     '.doc, .docx extentions
            Set wdApp = CreateObject("word.Application")
            Set wdDoc = wdApp.documents.Open(fle.Value, ReadOnly:=True)
            Set oRng = wdDoc.Range
            With oRng.Find
                Do While .Execute(FindText:=strsearch, MatchCase:=False)
                    i = i + 1
                Loop
            End With
            wdDoc.Close 0
            Set oRng = Nothing
            Set wdDoc = Nothing
            Set wdApp = Nothing
            If i <> 0 Then
                Sheet3.Cells(k, 1).Value = i
                Sheet3.Cells(k, 2).Value = fle.Value
                k = k + 1
                i = 0
            End If

        ElseIf InStr(1, fle.Value, ".ppt") > 0 Then      '.ppt, .pptx, .pptm extentions
            Set pptApp = CreateObject("powerpoint.Application")
            Set pptdoc = pptApp.presentations.Open(fle.Value, ReadOnly:=True)
            For Each osld In pptdoc.slides
                For Each oshp In osld.Shapes
                    If oshp.HasTextFrame Then
                        If oshp.TextFrame.HasText Then
                            Set otext = oshp.TextFrame.TextRange
                            Set foundText = otext.Find(findwhat:=strsearch)
                            Do While Not (foundText Is Nothing)
                                lngCount = lngCount + 1
                                With foundText
                                    Set foundText = otext.Find(findwhat:=strsearch, After:=.Start + .Length - 1)
                                End With
                            Loop
                        End If
                    End If
                Next oshp
            Next osld
            pptdoc.Close
            Set pptdoc = Nothing
            Set pptApp = Nothing
            Set otext = Nothing
            Set foundText = Nothing
            If lngCount <> 0 Then
                Sheet3.Cells(k, 1).Value = lngCount
                Sheet3.Cells(k, 2).Value = fle.Value
                k = k + 1
                lngCount = 0
            End If

        End If
    Next fle
Else:
    MsgBox "Enter text in cell 'B1' before searching."
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Answer 1

Here are some of my tips, how to speed the code up.

Create Applications Once

You are creating a new instance of word/power point for each relevant file extension, for ex. Set wdApp = CreateObject("word.Application").
Try to do this only ONCE for the whole runtime. You can add a check, if the wdApp/pptApp is nothing.
Also, consider using early binding for these applications. Go to Tools> References> and find what you need.

Use Variant array instead of Range

Replace the loop For Each fle In Sheet2.Range("A:A") with something like

Dim FileNamesArray as Variant
Dim FileName as Variant
FileNamesArray = Sheet2.Range("A:A").Value2
For Each FileName in FileNamesArray

This has significant impact on performance, see C. Williams article UDF part 1

Consider using Regular Expressions, global search

You can use RegEx, using global search, and get the Matches.Count. See secret example.
You can ise VBScript Regular Expressions for this.

Use Range.Value2 instead of Range.Value

Another small improvement is to use the Range.Value2 instead of Range.Value. More can be read in the C. Williams article UDF part 1.

Use Dir *.extension to target only one type of files in one loop

You can use Dir function with specific file extension to target only one type of files in one go. Therefore you don't have to check the InStr multiple times.

Use With statement extensively

Minor efect, but still counts. Whenever you are targeting the same Object, or variable, use With...End With block.

Answer 2

Sheet3.Cells(k, 1).Value = lngCount
Sheet3.Cells(k, 2).Value = fle.Value

I think the bottleneck is where you write something to the sheet.

---

Application.ScreenUpdating = False

Disabling screen-updating is often not enough. You also need to disable caclcations and events with

Application.EnableEvents = False
Application.Calculation = xlCalculationManual

when you're done you restore the values

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic