Question

在此页面

https://www.extendoffice.com/documents/word/966-word-split-documents-into-multiple-documents.html?page_comment=2

我得到了这个正常工作的VBA，它不会保持文本格式

Sub SplitNotes(delim As String, strFilename As String)
    Dim doc As Document
    Dim arrNotes
    Dim I As Long
    Dim X As Long
    Dim Response As Integer
    arrNotes = Split(ActiveDocument.Range, delim)
    Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections.Do you wish to proceed?", 4)
    If Response = 7 Then Exit Sub
    For I = LBound(arrNotes) To UBound(arrNotes)
        If Trim(arrNotes(I)) <> "" Then
            X = X + 1
            Set doc = Documents.Add
            doc.Range = arrNotes(I) ' does NOT keep formatting wdFormatOriginalFormatting
            doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
            doc.Close True
        End If
    Next I
End Sub

Sub test()
    'delimiter & filename
    SplitNotes "///", "Notes "
End Sub

这个问题听上去是一样的，但是将实现留给读者。

Split Word document into multiple parts and keep the text format

如何更改上面粘贴的代码，以保持///和下一个///（或文件末尾）之间的文本格式

甚至更好的是，分割为HEADING1格式，保留标题并保存名称为heading的文件

Answer 1

好的，这是一个概念，需要工作：

Sub SplitNotes(delim As String, strFilename As String)
    Dim doc As Document
    Dim arrNotes
    Dim I As Long
    Dim X As Long
    Dim Response As Integer

    Dim rngFound As Range
    Set rngFound = ActiveDocument.Range
    rngFound.Collapse wdCollapseStart

    rngFound.Select

    With Selection.Find
        .Text = delim
        .MatchWholeWord = True
        Do While .Execute(Forward:=True)
            rngFound.End = Selection.Range.Start
            Set doc = Documents.Add
            doc.Range.InsertXML rngFound.WordOpenXML
            doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
            doc.Close True
            rngFound.Start = Selection.Range.End
            rngFound.End = Selection.Range.End
        Loop
    End With

    rngFound.End = ActiveDocument.Range.End
    Set doc = Documents.Add
    doc.Range.InsertXML rngFound.WordOpenXML
    doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
    doc.Close True
End Sub


Sub test()
    'delimiter & filename
    SplitNotes "///", "Notes "
End Sub

此解决的主要问题是保留格式。而不是保存文本，而是保存基础XML。这将意味着数组很大...如果文档很大，可能会阻塞。

我想如果它不起作用，那是因为分隔符在XML中的表示方式有所不同，在这种情况下，您可以更改分隔符并再次进行测试。

Answer 2

OP已请求一个宏以给定的标题样式拆分文档。以下代码就是这样做的，可以按原样用作上面的代码修改的参考。

有一些警告。

复制格式化的文本时，页眉和页脚以及字段和标题编号可能会出现问题。即

缺少页眉和页脚，在这种情况下，宏需要扩展以在文档的所选部分的每个部分中复制三个页眉和页脚

依赖于其他字段（例如seq字段）的字段将受到缺少它们所依赖的字段（例如您选择的第一个序列字段将变为1。

编号的标题也可以从1还原为编号，但这在文档本身中相对容易重置。

这是我在StackOverflow上的第一篇文章，因此我希望它符合礼节并对OP有所帮助。

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

将Word文档拆分为新文件，并保持格式

2 个答案: