Чтение папки и сортировка данных

[Consoled]

У меня есть папка из множества файлов
и из каждого txt мне нужно вытянуть всю информацию которая находиться под ключевым словом вплоть до пустой строки
и внести в таблицу

Sub keyword()
    Dim s, s0, p, w, i, j, k, Path, f, qq
    Dim FSO As Object, File As Object, TextStream As Object
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("select * from Òàáëèöà1")
    Path = "F:\Àâðîðà\text reestr\"
     qq = Dir(Path & "*.txt*")
    Do Until s = ""
    Set FSO = CreateObject("Scripting.FileSystemObject")
        Set File = FSO.GetFile(Path & qq)
        Set TextStream = File.OpenAsTextStream(1)
        f = TextStream.ReadAll()
    Do While Not EOF(1)
        s = s & "=" & s0
    Loop
    Close #1
    
    s = "=" & s
    w = Array("Состав", "Производитель")
    p = Split(s, "==")
    rst.AddNew
    For i = 0 To UBound(p)
        For j = 0 To UBound(w)
            If w(j) = Left(p(i), Len(w(j))) Then
                k = k + 1
                rst(k) = Replace(p(i), "=", vbCrLf)
            End If
        Next
    Next
    If k > 0 Then rst.Update
qq = Dir
Loop
End Sub

Ошибок не выбивает,но не работает
P.S.
Если кто-то сможет сюда еще запихнуть чтобы читало в каждом файле еще и 6-7 строку(Название иногда в 6 иногда в 7) и кидало в новое поле было бы чудесно ,а то ключевых слов нету,а я не силен в access
Заранее спасибо.

[shanemac51]

ВЫ ВЗЯЛИ КОД С СОСЕДНЕГО ФОРУМА
но править пришлось почти каждую строчку

Option Compare Database
Option Explicit

Sub keyword72()
    Dim s, s0, p, w, i, j, k, Path, f, qq
    Dim FSO As Object, File As Object, TextStream As Object
    Dim rst As DAO.Recordset
    
    s = "select * from [" & Chr(210) & Chr(224) & Chr(225) & Chr(235) & Chr(232) & Chr(246) & Chr(224) & "1]"
    Debug.Print s
    Set rst = CurrentDb.OpenRecordset(s)
    ''Path = "F:\" & Chr(192) & Chr(226) & Chr(240) & Chr(238) & Chr(240) & Chr(224) & "\text reestr\"
    Path = "C:\TEMP\"
    
    Debug.Print Path
     qq = Dir(Path & "M0*.txt*")
    Do Until qq = ""
    Set FSO = CreateObject("Scripting.FileSystemObject")
        Set File = FSO.GetFile(Path & qq)
        Set TextStream = File.OpenAsTextStream
        f = TextStream.ReadAll()
    ''Do While Not EOF(1)
        s = Replace(f, vbCrLf, "=")
    ''Loop
    Close #1
    
    s = s & "="
    w = Array("Состав", "Производитель")
    p = Split(s, "==")
    rst.AddNew
    
    For i = 0 To UBound(p)
    Debug.Print i, Left(p(i), 50)
    k = 1
        For j = 0 To UBound(w)
        Debug.Print j, "===", w(j), Len(w(j))
        
            If w(j) = Left(p(i), Len(w(j))) Then
                k = k + 1
                rst(k) = Replace(p(i), "=", vbCrLf)
                rst(4) = qq
            End If
        Next
    Next
    If k > 0 Then rst.Update
qq = Dir
Loop
End Sub

[Consoled]

Сообщение от shanemac51

но править пришлось почти каждую строчку

Спасибо за ответ,но увы таблицу заполняет пустыми строками

[shanemac51]

Сообщение от shanemac51

qq = Dir(Path & "M0*.txt*")

может у вас таких файлов нет..я же настроилась на свои файлы и каталоги
РАСПАКУЙТЕ В КАТАЛОГ C:\TEMP\ZTXT\

[Consoled]

Сообщение от shanemac51

qq = Dir(Path & "M0*.txt*")

Путь я конечно менял,но и попробовал так как Вы сказали,но увы
Меняю файлы удаляет все поля в таблице и все
Менял только слова поиска,расположение файлов да ту самую строку ставил на считывание любых txt

[Consoled]

Вот все тут,извините что напрягаю и спасибо за помощь

[shanemac51]

НАДО ВЫКЛАДЫВАТЬ БОЛЕЕ РЕАЛЬНЫЙ ФАЙЛ --ТОГДА И ОТВЕТ БУДЕТ БОЛЕЕ РЕАЛЬНЫЙ

в 00001 есть склад и виробник, но нет price
поэтому и нет записи

даже слово инструкция по разному написана
ІНСТРУКЦІЯ
ИНСТРУКЦИЯ

и у вас намного больше пустых строк, даже сразу после ключевых строк

[Consoled]

Файлы разные,не все смог посмотреть
Часть такие как я дал Пример
Часть что приложил к таблице
Извините за неудобства ,файлов много все просмотреть не могу
Но суть такая же
Просто взять слово не состав как ключевое,а доп. вещества
А с производителем просто до конца файла это последний пункт во всех файлах

[Consoled]

Проверил оригиналы файлов,в них нету пустых строк после ключевых
Скорее всего это эффект после замены ваших файлов моими (пробовал убирать после запуска опять ставит строки)

[shanemac51]

выложите или пришлите на почту парочку оригиналов
пока я вижу 2 варианта

--первая половина текстовика на украинском, вторая на русском
--в первый раз вы выкладывали чисто английские
--возможно есть чисто русский и/или другие языки, а значит и другие ключевые слова(когда файлов --тысячи, это неизбежно.....
--иногда значение параметра на одной строке с именем, иногда через пустую строку