VBA - Excel - 通过文件夹中的多个文件搜索多个字符串

Question

我从 VBA 和编程开始。

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

到目前为止我的代码：

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

感谢您的帮助。

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

spreadsheet

蓝色 = 我搜索的值。 红色 = 我想写“找到”或“未找到”的地方。

编辑：

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

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 = 无 结束子

Answer 1

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

我建议您对您的代码进行以下（注释）重构：

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