question

ArunJayakumar-4812 avatar image
0 Votes"
ArunJayakumar-4812 asked ArunJayakumar-4812 answered

Excel VBA search

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.

office-vba-dev
5 |1600 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.

$$ANON_USER$$ avatar image
0 Votes"
$$ANON_USER$$ answered

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.

5 |1600 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.

ArunJayakumar-4812 avatar image
0 Votes"
ArunJayakumar-4812 answered

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

5 |1600 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.