用于在所有文件夹和子文件夹中搜索文本文件的vba代码

2 回答

• 0

  我相信这个答案将帮助您回答您的问题 .

  使用通配符打开Excel工作簿

  在VBA中，您不能使用*等通配符来打开文件 . 如果文件名和位置没有更改，则需要编译所有文件名的列表 .

  然后，您可以获取列表，打开列表中的每个文件，并使用find（）函数扫描文本doc以搜索关键字 . 如果找到，则返回文件名 .

  你面临的问题是编译文件位置来制作列表，我没有答案 . 其余的很容易 .

  回复于 2024-04-29T08:50:21+08:00
• 0

  以下代码可以帮助您

  Option Explicit
  Public Function RecursiveDir(colFiles As Collection, _
                               strFolder As String, _
                               strFileSpec As String, _
                               bIncludeSubfolders As Boolean)
  
  Dim strTemp As String
  Dim colFolders As New Collection
  Dim vFolderName As Variant
  
      'Add files in strFolder matching strFileSpec to colFiles
      strFolder = TrailingSlash(strFolder)
      strTemp = Dir(strFolder & strFileSpec)
      Do While strTemp <> vbNullString
          colFiles.Add strFolder & strTemp
          strTemp = Dir
      Loop
  
      If bIncludeSubfolders Then
          'Fill colFolders with list of subdirectories of strFolder
          strTemp = Dir(strFolder, vbDirectory)
          Do While strTemp <> vbNullString
              If (strTemp <> ".") And (strTemp <> "..") Then
                  If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                      colFolders.Add strTemp
                  End If
              End If
              strTemp = Dir
          Loop
  
          'Call RecursiveDir for each subfolder in colFolders
          For Each vFolderName In colFolders
              Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
          Next vFolderName
      End If
  
  End Function
  
  Public Function TrailingSlash(strFolder As String) As String
      If Len(strFolder) > 0 Then
          If Right(strFolder, 1) = "\" Then
              TrailingSlash = strFolder
          Else
              TrailingSlash = strFolder & "\"
          End If
      End If
  End Function
  
  Function SearchTxtFile(ByVal txtFileName As String, txtSearch As String) As Boolean
  
  Dim fso As Object 'Scripting.FileSystemObject
  Dim myFile As Object 'Scripting.TextStream     
  Dim ReadAllTextFile As Variant
  
      Set fso = CreateObject("Scripting.FileSystemObject")
      ' Open the file for input.
      Set myFile = fso.OpenTextFile(txtFileName, ForReading)
  
      ' Read from the file.
      If myFile.AtEndOfStream Then
          ReadAllTextFile = ""
      Else
          ReadAllTextFile = myFile.ReadAll
      End If
  
      If InStr(1, ReadAllTextFile, txtSearch, vbTextCompare) > 0 Then
          SearchTxtFile = True
      Else
          SearchTxtFile = False
      End If
  
  End Function
  Sub TestSearchFiles()
  
  Dim colFiles As New Collection
  Const txtPattern = "Business"
  Const YOUR_START_DIR = "Your Dir"
  
      RecursiveDir colFiles, YOUR_START_DIR, "*.TXT", True
  
      Dim vFile As Variant
      For Each vFile In colFiles
          If SearchTxtFile(vFile, txtPattern) Then
              Debug.Print vFile
          End If
      Next vFile
  
  End Sub
  

  编辑以下代码将给出完整路径的路径名

  Function GetDirectory(path)
     GetDirectory = Left(path, InStrRev(path, "\"))
  End Function
  

  在上面的代码中改变debug.print行

  Debug.Print vFile, GetDirectory(vFile)
  

  那是你要的吗？

  EDIT2：改变搜索功能

  Function SearchTxtFile(ByVal txtFileName As String, txtSearch() As Variant) As Boolean
  
  Dim fso As Object    'Scripting.FileSystemObject
  Dim myFile As Object    'Scripting.TextStream
  Dim ReadAllTextFile As Variant
  Dim i As Long
  
      Set fso = CreateObject("Scripting.FileSystemObject")
      ' Open the file for input.
      Set myFile = fso.OpenTextFile(txtFileName, ForReading)
  
      ' Read from the file.
      If myFile.AtEndOfStream Then
          ReadAllTextFile = ""
      Else
          ReadAllTextFile = myFile.ReadAll
      End If
  
      For i = LBound(txtSearch) To UBound(txtSearch)
          If InStr(1, ReadAllTextFile, txtSearch(i), vbTextCompare) > 0 Then
              SearchTxtFile = True
          Else
              SearchTxtFile = False
              ' If just one string is not found
              ' no further search neccessary
              Exit Function
          End If
      Next
  
  End Function
  

  测试它

  Sub TestSearchFiles()
  
  Dim colFiles As New Collection
  Dim txtPattern() As Variant
  Const YOUR_START_DIR = "Your directory here"
  
      txtPattern = Array("Pattern1", "Pattern2")
      RecursiveDir colFiles, YOUR_START_DIR, "*.TXT", True
  
      Dim vFile As Variant
      For Each vFile In colFiles
          If SearchTxtFile(vFile, txtPattern) Then
              Debug.Print vFile, GetDirectory(vFile)
          End If
      Next vFile
  
  End Sub
  

  回复于 2024-04-29T08:50:21+08:00