Update current macro in searching string in folder and put the result in column

[darkhangelsk]

Hi,

I currently have a macro to search words in folder and put the result in my excel. However, it only gives me one result where i want to give me all words found in the text files available in the folder.

Sample: If i have 2 words found on the text1.txt it will give me the result 2 rows showing the words found on that file, and so on for the next file.

I tried to tweak it, but not successful. i hope someone can get me the new code. Thanks in advance!

Here's my current code:

' These 5 lines must go at' the top of the module:
Const ForReading = 1
Dim m_vntSearchItems As Variant
Dim m_astrResults() As String
Dim m_objFileSystem As Object
Dim m_lngCounter As Long
Public Sub SearchFiles()
' ++++++++++++++++++' 
RUN THIS PROCEDURE'
 ++++++++++++++++++
 Const strFOLDER_PATH = "C:\Doucments\Logs" ' <-- the folder you want to search  
Dim i As Integer  
Dim j As Long    

On Error GoTo ErrorHandler  
m_vntSearchItems = Array("the", "and", "that", "have") ' <-- the items you want to search for  
Erase m_astrResults  
m_lngCounter = 0    

Set m_objFileSystem = CreateObject("Scripting.FileSystemObject")  
Call SearchFilesInFolder(strFOLDER_PATH)    

If m_lngCounter > 0 Then    
With ThisWorkbook.Sheets.Add      
   With .Range("A1:C1")        
   .Value = Array("Folder Path", "File Name", "Text Found")        
   .Font.Bold = True      
End With
      For j = 1 To m_lngCounter
        For i = 1 To UBound(m_astrResults)
          .Cells(j + 1, i).Value = m_astrResults(i, j) 
       Next i
      Next j
      With .Columns("A:C")
        .AutoFilter
        .AutoFit
      End With
    End With
    With ThisWorkbook.Windows(1)
      .SplitRow = 1
      .FreezePanes = True
    End With
  End If
    MsgBox Format(m_lngCounter, "#,0") & " file(s) were found.", vbInformation

ExitHandler:
  Set m_objFileSystem = Nothing
  Exit Sub  ErrorHandler:
  MsgBox Err.Description, vbExclamation
  Resume ExitHandler
End Sub

Private Sub SearchFilesInFolder(strFolderPath As String)
  Dim strFileExtension As String
  Dim objTextStream As Object
  Dim objSubfolder As Object
  Dim strFilePath As String
  Dim strFileText As String
  Dim objFolder As Object
  Dim objFile As Object
  Dim i As Integer
    On Error GoTo ExitHandler
  Set objFolder = m_objFileSystem.GetFolder(strFolderPath)
    For Each objFile In objFolder.Files 
   On Error GoTo FileHandler
    strFilePath = objFile.Path
    strFileExtension = LCase(m_objFileSystem.GetExtensionName(strFilePath))
    If strFileExtension = "txt" Or strFileExtension = "csv" Then
      Set objTextStream = m_objFileSystem.OpenTextFile(strFilePath, ForReading)
      strFileText = objTextStream.ReadAll()
      objTextStream.Close
      For i = LBound(m_vntSearchItems) To UBound(m_vntSearchItems)
        If InStr(1, strFileText, m_vntSearchItems(i), vbTextCompare) > 0 Then
          m_lngCounter = m_lngCounter + 1
          ReDim Preserve m_astrResults(1 To 3, 1 To m_lngCounter)
          m_astrResults(1, m_lngCounter) = objFile.ParentFolder
          m_astrResults(2, m_lngCounter) = objFile.Name 
         m_astrResults(3, m_lngCounter) = m_vntSearchItems(i)
          Exit For
        End If
      Next i
    End If
    GoTo NextFileFileHandler:
    Err.Clear
    Resume NextFileNextFile:
    On Error Resume Next
    objTextStream.Close
  Next objFile
    On Error
 GoTo ExitHandler
  For Each objSubfolder In objFolder.SubFolders
    On Error GoTo SubFolderHandler
    Call SearchFilesInFolder(objSubfolder.Path)
    GoTo NextSubFolderSubFolderHandler:
    Err.Clear
    Resume NextSubFolderNextSubFolder:
  Next objSubfolder
  ExitHandler:
  Set objTextStream = Nothing
  Set objSubfolder = Nothing
  Set objFolder = Nothing
  Set objFile = Nothing
End Sub

 

[darkhangelsk]

Anyone please?

Thanks...