VBA – Excel – 通过文件夹中的多个文件search多个string

我从VBA和程序开始。

我有一个X值的电子表格。 每个值与文件夹中的.xml文件匹配（或不匹配）（该值存在于xml标题中）。 我需要的是，对于这些值中的每一个，我的程序都会search匹配的.xml文件，并在电子表格中的值旁边写上“found”或“not found”。

我的代码到目前为止：

Sub StringExistsInFile() Dim theString As String Dim path As String Dim StrFile As String Dim fso As New FileSystemObject Dim file As TextStream Dim line As String theString = Sheets("PHILA_RESULT_PART_201703210429").Cells(i + 1, 2).Value path = "C:\Users\Jira\Desktop\LaPoste\20170324_120939_export_phila_commande.Envoi1\" StrFile = Dir(path & "*.xml") i = 1 Do While StrFile <> "" Set file = fso.OpenTextFile(path & StrFile) Do While Not file.AtEndOfLine line = file.ReadLine If InStr(1, line, theString, vbTextCompare) > 0 Then Sheets("PHILA_RESULT_PART_201703210429").Cells(i + 1, 14).Value = "found" i = i + 1 Exit Do End If Loop file.Close Set file = Nothing Set fso = Nothing StrFile = Dir() Loop End Sub 

谢谢您的帮助。

价值如何存储在电子表格中：

电子表格

蓝色=我search的值。 在红色=我想写“find”或“找不到”的地方。

编辑：

有一些“改进”后，我的代码

 Sub StringExistsInFile() Dim theString As String Dim path As String Dim StrFile As String Dim fso As New FileSystemObject Dim file As TextStream Dim line As String theString = Sheets("PHILA_RESULT_PART_201703210429").Cells(i + 1, 2).Value path = "C:\Users\Jira\Desktop\LaPoste\20170324_120939_export_phila_commande.Envoi1\" StrFile = Dir(path & "*.xml") i = 1 Do While Sheets("PHILA_RESULT_PART_201703210429").Cells(i + 1, 2).Value <> "" Set file = fso.OpenTextFile(path & StrFile) Do While Not file.AtEndOfLine line = file.ReadLine If InStr(1, line, theString, vbTextCompare) > 0 Then Sheets("PHILA_RESULT_PART_201703210429").Cells(i + 1, 14).Value = "found" Else Sheets("PHILA_RESULT_PART_201703210429").Cells(i + 1, 14).Value = "not found" End If Loop i = i + 1 file.Close Set file = Nothing StrFile = Dir() Loop 

设置fso = Nothing End Sub

Answer 1

我认为有一个逻辑缺陷：只要当前打开的文件当前行匹配的theString ，你的Exit Do停止读取该文件，但你然后继续检查其他文件和更新行索引

我build议你对你的代码进行如下（注释）重构：

 Option Explicit Sub StringsExistInFiles() Dim path As String Dim fso As FileSystemObject Dim filesPath As Variant Dim cell As Range Set fso = New FileSystemObject path = "C:\Users\Jira\Desktop\LaPoste\20170324_120939_export_phila_commande.Envoi1\" If Not GetFilesWithGivenExtension(fso, path, "xml", filesPath) Then Exit Sub '<--| exit if no files with given extension in given path With Sheets("PHILA_RESULT_PART_201703210429") '<--| reference your sheet For Each cell In .Range("B2", .Cells(.Rows.count, 2).End(xlUp)) '<--| loop through its column "B" cells from row 2 down to last not empty one StringExistsInFiles fso, filesPath, cell '<--| check all files for the exitence of the current cell content and write the result in corresponding column N cell Next End With End Sub Sub StringExistsInFiles(fso As FileSystemObject, filesPath As Variant, cell As Range) Dim line As String Dim filePath As Variant Dim found As Boolean With fso '<--| reference passed FileSystemObject For Each filePath In filesPath '<--| loop through all passed paths With .OpenTextFile(filePath) '<--| reference current path file Do While Not .AtEndOfLine '<--| loop until referenced file last line line = .ReadLine '<--| read referenced file current line If InStr(1, line, cell.Value, vbTextCompare) > 0 Then '<--| if passed string is found in referenced file current line found = True '<--| mark you made it Exit Do '<--| stop reading referenced file further lines End If Loop .Close '<--| close referenced file If found Then Exit For '<--| if you made it then stop reading further files End With Next cell.Offset(, 12).Value = IIf(found, "found", "not found") End With End Sub Function GetFilesWithGivenExtension(fso As FileSystemObject, folderToSearch As String, extensionToFind As String, files As Variant) As Boolean Dim fsoFile As file Dim nFiles As Long With fso.GetFolder(folderToSearch) '<--| reference passed folder ReDim files(1 To .files.count) '<--| size paths array to the number of files in referenced folder For Each fsoFile In .files '<--| loop through referenced folder files If fso.GetExtensionName(fsoFile) = extensionToFind Then '<--| if current file extension matches passed one nFiles = nFiles + 1 '<--| update valid files counter files(nFiles) = fsoFile.path '<--| store current valid file path in paths array End If Next End With If nFiles > 0 Then '<--| if any valid file found ReDim Preserve files(1 To nFiles) '<--| resize paths array correspondingly GetFilesWithGivenExtension = True '<--| return successful result End If End Function