Читать абзацы из большого текстового файла и вставлять в нужные ячейки

[domo22]

Помогите составить макрос для Excel 2003-2007, который будет читать информацию в виде группы абзацев из огромного текстового файла "Образец базы.txt" в кодировке 1251, удалять знаки абзаца и пробелы в конце и в начале группы, заменять остальные знаки перевода строки на символы типа "^n", и вставлять полученную информацию в соответствующую ячейку, напротив ячейки с идентификатором. Идентификаторы в файл Excel уже считаны и распределены по нужным ячейкам. Если нужной информации нет - вставлять строку типа "Not found".

Информация в каждой группе текста разделена маркерами вида "#НАЧАЛО#" и "#КОНЕЦ#".

Пример исходного и того, что должно получиться:

[IgorGO]

я бы рекомендовал:

в соответствующую ячейку, напротив ячейки с идентификатором

зразу

- вставлять строку типа "Not found"

[n_lomov]

Исхожу из предположения, что индентификаторы были считаны из этого же текстового файла.
Импортирую файл в эксель, используя в качестве разделителя #, от левой верхней ячейки пустого листа.
В этом же листе:

Sub Griby()
   Dim d As Long, e As Long
   Dim i As Long, j As Long
   Dim ID As Integer, Info As Integer
   Const NovStr As String = "^n" 'символ перевода строки
   i = 1
   j = 1
   d = 1
   ID = 4 'столбец идентификаторов
   Info = 5 'столбец с описаниями
   Do While i <= ActiveSheet.UsedRange.Rows.Count
      If Cells(i, 2) = "НАЧАЛО" Then
         j = i + 1
         Do While Cells(j, 1) <> "@ОПИСАНИЕ@"
            If IsEmpty(Cells(d, ID)) Then
               Cells(d, ID) = Cells(j, 1)
            Else
               Cells(d, ID) = Cells(d, ID) & NovStr & Cells(j, 1)
            End If
            j = j + 1
         Loop
         j = j + 1
         Do While Cells(j, 2) <> "КОНЕЦ"
            If IsEmpty(Cells(d, Info)) Then
               Cells(d, Info) = Cells(j, 1)
            Else
               Cells(d, Info) = Cells(d, Info) & NovStr & Cells(j, 1)
            End If
            j = j + 1
         Loop
         d = d + 1
         i = j
      End If
      i = i + 1
   Loop
End Sub

Получается таблица в ячейке D4 того же листа, где один столбец - идентификаторы, другой - описание.
P.S. Я рад бы избавиться от кучи невнятных переменных и уродских вложенных циклов, но не знаю, как.

[doober]

Можно так.
Поменяйте путь к текстовику на ваш.

[domo22]

n_lomov, спасибо за труд. Однако, к сожалению, макрос у меня в данном виде не работает.

Во-первых, он разбирает только первую запись и останавливается, возможно потому, что в операторе
Do While i <= ActiveSheet.UsedRange.Rows.Count
"ActiveSheet.UsedRange.Rows.Cou nt" всегда равно 1 (на excel 2003).
Кроме того, даже если явно указать количество строк на листе (Do While i <= 100000), макрос вылетает с ошибкой "400" на второй же записи на операторе
Cells(d, ID) = Cells(d, ID) & NovStr & Cells(j, 1)

Во-вторых, он не убирает пробелы и знаки новой строки в начале и в конце каждой записи. Не критично, но нужно.

И последнее, главное, он не распределяет записи согласно имеющимся идентификаторам, а строит сам этот список идентификаторов. Это, конечно, бывает полезно, но не в данном случае.

Может быть, макрос можно доработать?

-----------------------------------------------
doober, cпасибо за макрос, но он тоже не работает. Проблемы такие.
Разобрав часть базы он вылетает с ошибкой "Out of memory", например на операторе
Sh.Cells(XX.Row, 8) = RR
хотя это наверно не важно. У меня 2 Гб ОЗУ.

Кроме того, он удаляет знаки новой строки (т.е. пустые строки) в середине каждой записи, а должен только в начале и в конце записи. А в середине, из-за ограничений Excel, заменять на что-либо, например на строку "^N^" или подобную.

Также он уничтожает все символы вертикальной черты "|", которые встречаются в базе, хотя этого делать не надо.

И последнее, строки в Excel получаются огромной высоты, листать такой файл практически невозможно.

Можно ли макрос исправить?

[doober]

Все можно.
На файлообменник текстовый файл,исходный файл excel для заполнения(состояние перед выполнением макроса),и дальше будем посмотреть.
Если у вас файл больше 30 метров,конечно надо использовать другой алгоритм

[domo22]

n_lomov, проведя дополнительные эксперименты, я выяснил, что был не совсем прав - макрос может работать так, как вы говорите, но только его нужно запускать с активного листа, а не с любого, и нельзя править что-либо на листе. Тогда вроде бы правильно определяется количество строк в операторе
While i <= ActiveSheet.UsedRange.Rows.Count
Но мне кажется, что более надежно было бы что-то такое:

Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
Do While i <= LastRow

Также выяснились 2 причины, по которым ваш макрос вылетал:
- если строка в базе начинается со знака равно "=", макрос вылетает;
- при предварительном импорте текстового файла по непонятным причинам некоторые строки импоритруются с ошибкой, причину я не нашел, но особенно часто, когда строки начинаются с дефиса "-", например строка "- строка один" импортируется как "=- строка один" и снова макрос вылетает.

Если бы вы смогли устранить эти проблемы макрос был бы полезен, хотя и не для этой конкретной задачи.

Также очень неудобно импортировать файл вручную. Может Вы могли бы добавить в свой макрос что-то такое:

Const BaseFileName As String = "Образец базы.txt" 'имя файла базы
Const DirName As String = "C:\tmp\" 'папка файла базы
Const IDChar As String = "#" 'разграничитель

'перейти в первую ячейку и считать файл
Range("A1").Select
Workbooks.OpenText Filename:=DirName & BaseFileName, Origin:=1251, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlNone, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False, _
Space:=False, Other:=True, OtherChar:=IDChar, FieldInfo:=Array(Array(1, 1), _
Array(2, 1)), TrailingMinusNumbers:=True

PS
Я сейчас пытаюсь сгенерировать образец базы размером хотя бы пару метров, чтобы те, кто помогает мне, могли более реально оценить работу макросов.

[n_lomov]

Почему из-за знака = вылетает, не могу сказать. А импортировать можно следующим образом:

   With ActiveSheet.QueryTables.Add(Connection:= _
      "TEXT;" & DirName & BaseFileName, Destination:=Range( _
      "$A$1"))
      .TextFilePlatform = 1251
      .TextFileOtherDelimiter = IDChar
      .Refresh BackgroundQuery:=False
   End With

[Hugo121]

Чтоб не вылетало на "=" - ставьте Сперва ячейке текствый формат, или так: "'=..."

[domo22]

n_lomov, ваш код для импорта файла работает без проблем, спасибо. Теперь бы перенести нужные ячейки в соответствующее место на новый или текущий лист...

Hugo121, я не совсем понимаю, перед экспортом вставить оператор

ActiveWorksheet.Range("A:H").NumberFormat = "@"

или как?