VBA – Excel – поиск нескольких строк через несколько файлов в папке

Я начинаю с 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 

Спасибо за помощь.

Как значение хранится в электронной таблице:

таблица

В синем = значения, которые я ищу. В red = где я хочу написать «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 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

Я думаю, что есть логический недостаток: пока текущая текущая строка текущего файла соответствует строке 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 
Давайте будем гением компьютера.