Excel VBA search

Question

Hello, I need to create a Vb script to search for a keyword in different files (Xlsx,csv,txt) under different subfolders and write the result along with the file name in which the keyword is present.

Scenario

1000 folders in which 7 subfolders were present in those 1000folders, the script need to search for the keyword in every folder, files in it and return the result with its associate path where the keyword is found in the file.

Answer 1

Hello,

You can try this:

Private Keyword As String
Private ReturnedFilePath As String
Private KeywordLocationInFile As Integer

Sub FindKeyword()
    Dim FileSystem As Object
    Dim FolderToSearchIn As String

    Keyword = "Hello World"
    FolderToSearchIn = "C:\"
    Set FileSystem = CreateObject("Scripting.FileSystemObject")

    LoopThroughFolder (FileSystem.GetFolder(FolderToSearchIn))
    If Not ReturnedFilePath = "" Then
        MsgBox (ReturnedFilePath)
        MsgBox (KeywordLocationInFile)
    End If
End Sub

Sub LoopThroughFolder(Folder)
    Dim SubFolder
    Dim File

    For Each SubFolder In Folder.SubFolders
        LoopThroughFolder SubFolder
    Next
    For Each File In Folder.Files
       Dim strFilename As String
       Dim strFileContent As String
       Dim iFile As Integer

       strFilename = File
       iFile = FreeFile
       Open strFilename For Input As #iFile
            strFileContent = Input(LOF(iFile), iFile)
       Close #iFile
       If InStr(strFileContent, Keyword) > 0 Then
            ReturnedFilePath = File
            KeywordLocationInFile = InStr(strFileContent, Keyword)
            Exit Sub
       End If
    Next
End Sub

I hope it helps.

Answer 2

I tried the below code. After it identifies the keyword in document it throws the error 1004 Application or object defined error it doesn't print the file name

Public Sub searchText()
Dim FSO As Object
Dim folder As Object,
Dim wb As Object
Dim ws As Worksheet

searchList = Array("orange", "apple", "pear")    'define the list of text you want to search, case insensitive

Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "C:\test" 'define the path of the folder that contains the workbooks
Set folder = FSO.GetFolder(folderPath)
Dim thisWbWs, newWS As Worksheet

'Create summary worksheet if not exist
For Each thisWbWs In ActiveWorkbook.Worksheets
    If wsExists("summary") Then
        counter = 1
    End If
Next thisWbWs

If counter = 0 Then
    Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    With newWS
        .Name = "summary"
        .Range("A1").Value = "Target Keyword"
        .Range("B1").Value = "Workbook"
        .Range("C1").Value = "Worksheet"
        .Range("D1").Value = "Address"
        .Range("E1").Value = "Cell Value"
    End With
End If

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .AskToUpdateLinks = False
End With

'Check each workbook in main folder
For Each wb In folder.Files
    If Right(wb.Name, 3) = "xls" Or Right(wb.Name, 4) = "xlsx" Or Right(wb.Name, 4) = "xlsm" Then
        Set masterWB = Workbooks.Open(wb)
        For Each ws In masterWB.Worksheets
          For Each Rng In ws.UsedRange
            For Each i In searchList
                If InStr(1, Rng.Value, i, vbTextCompare) > 0 Then   'vbTextCompare means case insensitive. 
                    nextRow = ThisWorkbook.Sheets("summary").Range("A" & Rows.Count).End(xlUp).Row + 1
                    With ThisWorkbook.Sheets("summary")
                        .Range("A" & nextRow).Value = i
                        .Range("B" & nextRow).Value = Application.ActiveWorkbook.FullName
                        .Range("C" & nextRow).Value = ws.Name
                        .Range("D" & nextRow).Value = Rng.Address
                        .Range("E" & nextRow).Value = Rng.Value
                    End With
                End If
            Next i
          Next Rng
        Next ws
        ActiveWorkbook.Close True
    End If
Next

 With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
End With

ThisWorkbook.Sheets("summary").Cells.Select
ThisWorkbook.Sheets("summary").Cells.EntireColumn.AutoFit
ThisWorkbook.Sheets("summary").Range("A1").Select

End Sub

Function wsExists(wksName As String) As Boolean
On Error Resume Next
wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
On Error GoTo 0
End Function