ОП запросил макрос для разделения документа с заданным стилем заголовка. Следующий код делает именно это и может использоваться как есть в качестве справочного материала для внесения поправок в приведенный выше код.
Есть несколько предостережений.
При копировании форматированного текста могут возникнуть проблемы с верхними и нижними колонтитулами, а также с полями и нумерацией заголовков.
т.е.
Отсутствуют верхние и нижние колонтитулы, и в этом случае макрос должен расширяться для копирования трех верхних и нижних колонтитулов в каждом разделе выбранной части документа
Поля, которые зависят от других полей (например, полей seq), будут зависеть от отсутствия полей, от которых они зависят, например, первое поле последовательности в вашем выборе станет 1.
Нумерованные заголовки могут также вернуться к нумерации от 1, но это относительно легко сбросить в самом документе.
Это мой первый пост в StackOverflow, поэтому я надеюсь, что он соответствует этикету и полезен для ОП.
Option Explicit
Public Sub SaveAllChapters()
Dim myCollectionOfChapters As Collection
Dim myChapter As Word.Range
Set myCollectionOfChapters = GetAllChapters
For Each myChapter In myCollectionOfChapters
SaveChapter myChapter
Next
End Sub
Public Sub SaveChapter(thisChapter As Word.Range)
Dim myDoc As Word.Document
Set myDoc = Documents.Add
With myDoc
.Range.FormattedText = thisChapter.FormattedText
.SaveAs2 FileName:=safeName(thisChapter.Paragraphs.First.Range.Text)
.Close False
End With
End Sub
Public Function safeName(ByVal thisString As String) As String
'Ensures there are no illegal filename characters in a string to be used as a filename
Dim invalidFilenameCharacters() As String
Dim myIndex As Long
invalidFilenameCharacters = Split("9,10,11,13,34,42,47,58,60,62,63,92,124", ",")
For myIndex = 0 To UBound(invalidFilenameCharacters)
thisString = Replace(thisString, Chr$(invalidFilenameCharacters(myIndex)), Chr$(95))
Next
safeName = thisString
End Function
Public Function GetAllChapters() As Collection
Dim myCollection As New Collection
Dim myRange As Word.Range
Set myRange = Nothing
Do While GetChapter(myRange)
myCollection.Add myRange.Duplicate
Loop
Set GetAllChapters = myCollection
End Function
Public Function GetChapter(thisRange, Optional thisStyle As WdBuiltinStyle = wdStyleHeading1) As Boolean
' Searches backwards through the document from the start of thisRange
' thisRange is extended to include text upto, but not including the previous heading 1 style
' Returns false if the heading style is not found or if the start of the range matches the start of the document
Dim searchRange As Word.Range
If thisRange Is Nothing Then
Set thisRange = ActiveDocument.StoryRanges(wdMainTextStory)
thisRange.Collapse Direction:=wdCollapseEnd
Set searchRange = thisRange.Duplicate
Else
thisRange.Collapse Direction:=wdCollapseStart
Set searchRange = thisRange.Duplicate
End If
With searchRange.Find
.ClearFormatting
.Format = True
.Style = thisStyle
.Wrap = wdFindStop
.Text = vbNullString
.Forward = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If Not .Found Then
GetChapter = False
thisRange.Start = thisRange.Document.StoryRanges(wdMainTextStory).Start
thisRange.End = searchRange.End
Else
GetChapter = True
thisRange.Start = searchRange.Start
End If
End With
End Function