Searching a huge number of strings from Excel to a large number of Text files I have written this code to get the input string from the spreadsheet and search the string across the text files and state whether or not it is found in the Excel sheet.

Scenario:

Excel (sheet1):


ColumnA

AAA 

BBB



Drive C:

C: should be give in Column D5.

It has subfolders TEMP1, TEMP2, ...


Folder C:\TEMP1\

It has these text files: 


X1.txt (has content AAA) 
X2.txt (doesn't have any search data)

Folder C:\TEMP2\

It has these text files: 


Y1.txt (has content BBB) 
Y2.txt (doesn't have any search data)





Public K As Integer
Dim fs As Object
Dim fso As Object
Public fpth As String
Public str As String

Public Sub SearchInSQSDatabase_Click()

Dim ws1 As Worksheet
Set ws1 = Sheets(1)

Dim ws2 As Worksheet
Set ws2 = Sheets(2)

K = 2

Dim i As Integer
i = 1
ws2.Cells(1, 4).Value = "Search String"
ws2.Cells(1, 5).Value = "Files"
ws2.Cells(1, 6).Value = "Comments"

Do While Cells(i, 1).Value &lt;&gt; ""
     'ws2.Cells(i, 1).Value = Cells(i, 1).Value
     str = Cells(i, 1).Value
     ShowFolderList (ws1.Cells(5, 4).Value)
     i = i + 1
Loop


End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get the List of Files and folders
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ShowFolderList(folderspec)
   On Error GoTo local_err

 Dim f, f1, fc, s, sFldr

 Dim ws2 As Worksheet
 Set ws2 = Sheets(2)

 Set fs = CreateObject("Scripting.FileSystemObject")
 Set f = fs.GetFolder(folderspec)
 Set fc = f.SubFolders

  For Each f1 In fc
     ' If Right(f1, 1) &lt;&gt; "\" Then ShowFolderList f1 &amp; "\" Else ShowFolderList f1
     If Right(f1, 1) &lt;&gt; "\" Then ShowFolderList f1 Else ShowFolderList f1
  Next
Set fc = f.Files
For Each f1 In fc
    ' ws2.Cells(K, 4).Value = folderspec &amp; "\" &amp; f1.Name
    fpth = folderspec &amp; "\" &amp; f1.Name
    StringExistsInFile (f1.Name)

    'K = K + 1
Next
local_exit:
     Exit Sub
 local_err:
    MsgBox Err &amp; " " &amp; Err.Description
    Resume local_exit
    Resume
 End Sub

 ''''''''''''''''''''''''''''''''''''''''''''''''''''''
 'Check for the String
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub StringExistsInFile(fname)
Dim theString, callString As String
Dim path As String 
Dim StrFile As String
Dim file
Dim line As String
Dim flag As String

Set fso = CreateObject("Scripting.FileSystemObject")
Dim ws2 As Worksheet
Set ws2 = Sheets(2)

theString = str
path = fpth
StrFile = Dir(path)

Do While StrFile &lt;&gt; ""

'Find TheString in the file
'If found, debug.print and exit loop

Set file = fso.OpenTextFile(path)
Do While Not file.AtEndOfLine
    line = file.ReadLine
    If InStr(1, line, theString, vbTextCompare) &gt; 0 Then
        ws2.Cells(K, 4).Value = str
        ws2.Cells(K, 5).Value = fname
        ws2.Cells(K, 6).Value = "Srting is found"
        flag = "Y"
    End If


Loop

file.Close
Set file = Nothing
Set fso = Nothing

StrFile = Dir()
Loop
If flag = "Y" Then
   K = K + 1
 Else
  ws2.Cells(K, 4).Value = str
  ws2.Cells(K, 5).Value = fname
  ws2.Cells(K, 6).Value = "String is not Found"
   K = K + 1
  End If


  End Sub


Output:

Output should be written in sheet2:


ColumnA columnB 

AAA     X1 

BBB     Y1



I have updated the code to have a hyperlink in the text file name to open the text file for the strings that are found, also need to no the count of column

added the below logic at the end, I feel the below code can be written in better way 

Do While ws2.Cells(K, 6).Value &lt;&gt; ""
    K = K + 1
 Loop


Do While j &lt; K

If ws2.Cells(j, 7).Value &lt;&gt; "" Then

    ws2.Cells(j, 7).Hyperlinks.Add Anchor:=ws2.Cells(j, 7), Address:= _
    ws2.Cells(j, 7).Value, TextToDisplay:=ws2.Cells(j, 7).Value

    ' ws2.Cells(j, 7).Formula = "=HYPERLINK(" &amp; ws2.Cells(j, 7) &amp; ",    Address = " &amp; ws2.Cells(j, 7).Value &amp; ")"
    'ws2.Hyperlinks.Add Anchor:=j, _
    'Address:=ws2.Cells(j, 7).Value, TextToDisplay:=ws2.Cells(j, 7).Value

    End If
  j = j + 1
Loop
A few suggestions:


Most obvious (and simple) step is to read the entire file, and not one line at the time

Change this:

Set file = fso.OpenTextFile(Path)
Do While Not file.AtEndOfLine
    Line = file.ReadLine
    If InStr(1, Line, theString, vbTextCompare) &gt; 0 Then
        ws2.Cells(K, 4).Value = Str
        ws2.Cells(K, 5).Value = fname
        ws2.Cells(K, 6).Value = "Srting is found"
        flag = "Y"
    End If
Loop


To this:

Set file = fso.OpenTextFile(Path)

fullFile = file.ReadAll

If InStr(1, fullFile, theString, vbTextCompare) &gt; 0 Then
    With ws2
        .Cells(K, 4).Value2 = theString
        .Cells(K, 5).Value2 = fname
    End With
    flag = "Y"
End If


It eliminates the do-while loop. More details about .ReadAll().
Store Str and fname info into an array, then commit the entire array to the worksheet at the end, instead of writing to each cell separately.
The "Find" command in DOS might be faster and it can also provide the line number(s) where the string is found:

Find /?

Searches for a text string in a file or files.

FIND [/V] [/C] [/N] [/I] [/OFF[LINE]] "string" [[drive:][path]filename[ ...]]