Макрос: разбивание текста на отдельные файлы по заголовкам.

[Dimon_M]

Добрый день!
Выручите пожалуйста!
Есть файлы doc и rtf текст с таблицами и заголовками.
Необходимо из текста взять целиком заголовки (с текстом) и из каждого сделать отдельный файл, имя каждого файла = имени заголовка.

Есть очень хороший похожий вариант от viter.alex

Option Explicit

Sub DivideToChapters()
'Отключаем обновление экрана
Application.ScreenUpdating = False
On Error Resume Next
'Запоминаем основной документ в переменную
Dim oMainDoc As Document: Set oMainDoc = ActiveDocument 'Документ с текстом
'Запоминаем содержимое документа от положения курсора и до конца документа
Dim oRng As Range: Set oRng = oMainDoc.Range(Selection.Range.Star t, oMainDoc.Range.End)
'Создаем новый документ и запоминаем его переменную. В этот новый документ будет копироваться _
текст из каждой главы и сохраняться под своим именем
Dim oNewDoc As Document: Set oNewDoc = Documents.Add
'Переменные для работы: путь к каталогу, объект для скриптов, счетчик глав, имя главы
Dim sPath$, FSO, counter%, sName$
'Путь к каталогу, в который будут сохраняться главы. Имя каталога совпадает с именем файла
sPath = oMainDoc.Path & Application.PathSeparator & Mid(oMainDoc.Name, 1, InStrRev(oMainDoc.Name, ".") - 1)
'Создаем каталог на диске
Set FSO = CreateObject("Scripting.FileSystemO bject")
FSO.CreateFolder sPath
'Если каталог уже создан, то пропускаем ошибку
If Err.Number = 5 Then Err.Clear
Dim iStart&, iEnd& 'Переменные для хранения начала и конца главы
iStart = oRng.Start
'Производим поиск в документе по цвету текста. Цвет берем из первого символа после курсора.
With oRng.Find
.Font.Color = oMainDoc.Range(iStart, iStart + 1).Font.Color
'Если текст с таким цветом найден
While .Execute
If .Parent.Start <> iStart Then 'Отсекаем строку в которой находится курсор
counter = counter + 1
iEnd = .Parent.Start 'Конец главы
oMainDoc.Range(iStart, iEnd).Copy 'Копируем главу
oNewDoc.Range.Paste 'Вставляем в новый документ
oNewDoc.SaveAs sPath & Application.PathSeparator & counter & " " & sName & ".txt", wdFormatText 'Сохраняем как обычный текст
iStart = iEnd 'Конец предыдущей главы делаем началом следующей
End If
sName = Trim(Replace(.Parent.Text, vbCr, "")) 'Название главы
Wend
'Сохранение последней главы (до конца документа)
oMainDoc.Range(iStart, oMainDoc.Range.End).Copy
oNewDoc.Range.Paste
oNewDoc.SaveAs sPath & Application.PathSeparator & counter + 1 & " " & sName & ".txt", wdFormatText, addtorecentfiles:=False
End With
oNewDoc.Close False 'Закрываем документ
Application.ScreenUpdating = True: Application.ScreenRefresh 'Обновляем экран
End Sub

Но он не подходит.
Необходимо чтобы макрос брал заголовки (заголовок1 и заголовок2),и сохранял все под заголовком включая таблицы в том-же формате.

[shanemac51]

какой формат на выходе

что должны получить --где места разрыва(имеется в виду стык заг1-заг2)

название отчета
-------------------------------------
заголовок1 ллллллллллллл
заголовок2 лллллллллллллл
оооооооооооооооооооо
рррррррррррррррррррррр
таблицы
рисунки
--------------------------------------
. заголовок2 лллллллллллллл
ррррррррррррррррррр ооооооооооооо
------------------------------------
заголовок2 лллллллллллллл
ооооооооооооооооооооо
---------------------------------
заголовок1 ллллллллллллл
заголовок2 лллллллллллллл
оооооооооооооооооооо
рррррррррррррррррррррр
таблицы
рисунки
---------------------------------------
. заголовок2 лллллллллллллл
ррррррррррррррррррр ооооооооооооо
----------------------------------------
заголовок2 лллллллллллллл
ллллллллллллллллллллллллл

подписи
шшшшшшшшшшшшшшшшшшшшш шшшшшшшшшш шшшш

[Sasha_Smirnov]

Пока суд да дело, в режиме Структура вытяните нужные заголовки на Рабочий стол.

[viter.alex]

Sasha_Smirnov, я не знал о такой фишке, но в 2010 не получается у меня. Не вытягивается ничего

[Sasha_Smirnov]

Word плавно деградирует к WordPad!

Суть "вытягивания" — получение выделенного куска в виде отдельного документа (в той папке, где мы отпустили "тянущую" мышь). Может, для выделения, не нажали на плюсик:

[Казанский]

Было... http://programmersforum.ru/showthread.php?t=209102