将粗体句子之间的所有信息存储为数组元素，Word VBA

Question

我是 VBA 新手，我正在尝试从 VBA 中由章节内容组成的 400 页字文档创建一个数组。数组的每个元素都应包含从粗体章节标题到下一章节标题的所有段落。将其表述为章节标题之间的信息可能会更好。

章节标题是一个总是加粗的句子（也是文档中唯一加粗的部分）。章节描述后面的信息可能有多个段落和项目符号信息，但在少数情况下也可能完全为空。在章节内容为空的情况下，我希望存储某种空白条目。

我已经设法创建了一个数组，其中每个段落都作为数组元素。但是，由于有时每章有多个段落和项目符号部分，因此数组中的元素数量大于章节数量。该数组还将章节标题存储为它们自己的元素（尽管我想出了如何通过类似的比较从数组中删除标题）。今天研究了几个小时后，我有点迷失了。

将“粗体章节标题”之间的所有信息存储为数组中的元素的方法是什么？

非常感谢您的帮助！

    Sub addUnderlinedWordsToArray()
    On Error GoTo errhand:
    Dim myWords()       As String
    Dim i               As Long
    Dim myDoc           As Document: Set myDoc = ActiveDocument ' Change as needed
    Dim aRange          As Range: Set aRange = myDoc.Content
    Dim sRanges         As StoryRanges: Set sRanges = myDoc.StoryRanges
    Dim ArrayCounter    As Long: ArrayCounter = 0 ' counter for items added to the array
    Dim Sentence        As Range
    Dim Paragraph       As Range

    Dim w               As Variant
    Dim myDescs()       As String
    Dim x               As Variant

    Application.ScreenUpdating = False
    ReDim myWords(aRange.Words.Count) ' set a array as large as the
                                      ' number of words in the doc

    For Each Paragraph In ActiveDocument.StoryRanges
        For Each w In ActiveDocument.Paragraphs
                  myWords(ArrayCounter) = w
                 ArrayCounter = ArrayCounter + 1
        Next
    Next



On Error GoTo 0

    Set myDoc = Nothing
    Set aRange = Nothing
    Set sRanges = Nothing


    Set Ex0 = New Excel.Application
    Set Wb0 = Ex0.Workbooks.Add
    Ex0.Visible = True

    Wb0.Sheets(1).Range("A1").Resize(UBound(myWords) + 1, 1) = WorksheetFunction.Transpose(myWords)

    Application.ScreenUpdating = True

    Debug.Print UBound(myWords())

    Exit Sub

errhand:
    Application.ScreenUpdating = True
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
End Sub

Answer 1

下面的代码依赖于您的声明，即只有标题是粗体的。如果在第一个标题之前有任何未加粗的文本，则您需要添加代码以跳过此文本的非粗体文本。我最初使用类型来定义章节，但 VBA 一直给我神秘的错误消息，所以我恢复为数组。

返回的集合应该包含数组，其中 index(1) 是标题文本，index(2) 是正文。该代码是使用显式选项编写的，不会引起 Rubberduck 的检查问题。

Option Explicit

Sub testCompileChapters()

Dim ChapterCollection As Collection

    Set ChapterCollection = New Collection

    Set ChapterCollection = CompileChapters(ActiveDocument.Content)
    MsgBox "There are " & ChapterCollection.Count & " Chapters in your document", vbOK
    Debug.Print ChapterCollection.Item(1)(1).Text
    Debug.Print ChapterCollection.Item(1)(2).Text
End Sub

Public Function CompileChapters(ByRef this_range As Word.Range) As Collection

Dim my_chapter(1 To 2)  As Word.Range
Dim my_chapters         As Collection
Dim my_para             As Word.Paragraph
Dim my_range_start      As Long
Dim my_bold             As Long

    With this_range.Paragraphs(1).Range

        my_range_start = .Start
        my_bold = .Font.Bold

    End With

    Set my_chapters = New Collection

    For Each my_para In this_range.Paragraphs

        my_para.Range.Select

        If my_bold <> my_para.Range.Font.Bold Then

            With ActiveDocument.Range(Start:=my_range_start, End:=my_para.Range.Previous(unit:=wdParagraph).End)

                If my_bold = -1 Then

                    Set my_chapter(1) = .Duplicate

                Else

                    Set my_chapter(2) = .Duplicate
                    my_chapters.Add Item:=my_chapter

                End If

                my_bold = Not my_bold
                my_range_start = my_para.Range.Start

            End With

        End If

    Next

    Set my_chapter(2) = _
        ActiveDocument.Range( _
            Start:=my_range_start, _
            End:=ActiveDocument.Range.Paragraphs.Last.Range.End)

    my_chapters.Add Item:=my_chapter
    Set CompileChapters = my_chapters

End Function

上面的代码在下面的 6 章文档中检查正常。

这是粗体字 1
这不是粗体文本1
这不是粗体文本
这不是粗体文本
这是粗体文本 2
这不是粗体文本2
这不是粗体文本
这不是粗体文本
这是粗体文本 3
这不是粗体文本3
这不是粗体文本
这不是粗体文本
这不是粗体文本
这不是粗体文本
这是粗体文本 4
这不是粗体文本4
这不是粗体文本
这不是粗体文本
这是粗体文本 5
这不是粗体文本5
这不是粗体文本
这不是粗体文本
这是粗体文本 6
这不是粗体文本6
这不是粗体文本
这不是粗体字

Answer 2

如果您使用 Word 的“标题”功能，您可以使用这些功能。 “标题 1”或“标题 2”都是表示章节的对象，Word 已经使用它来构建目录。

此示例使用“标题 1”，但您可以使用任何其他内置样式：

Sub SelectData()
    Dim Doc As Word.Document
    Set Doc = ActiveDocument

    Dim findRange As Range
    Set findRange = Doc.Range

    findRange.Find.Style = "Heading 1"

    Dim startCopyRange As Long
    Dim endCopyRange As Long
    Do While findRange.Find.Execute() = True
        startCopyRange = findRange.End + 1
        endCopyRange = -1

        Dim myParagraph As Paragraph
        Set myParagraph = findRange.Paragraphs(1).Next

        Do While Not myParagraph Is Nothing
            myParagraph.Range.Select 'Debug only

            If InStr(myParagraph.Style, "Heading") > 0 Then
                endCopyRange = myParagraph.Range.Start - 0
            End If

            If myParagraph.Next Is Nothing Then
                endCopyRange = myParagraph.Range.End - 0
            End If

            If endCopyRange <> -1 Then
                Doc.Range(startCopyRange, endCopyRange).Select  'Debug only
                DoEvents
                Exit Do
            End If

            Set myParagraph = myParagraph.Next
            DoEvents
        Loop
    Loop
End Sub

来源： Finding heading of chapters in word file and copying individual paragraphs to new word file with VBA

Answer 3

尝试基于：

Sub Demo()
Application.ScreenUpdating = False
Dim ArrTxt, i As Long
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = "§"
      .Format = True
      .Font.Bold = True
      .Forward = True
      .Wrap = wdFindContinue
      .Execute Replace:=wdReplaceAll
    End With
    ArrTxt = Split(.Text, "§")
  End With
  .Undo 1
End With
Application.ScreenUpdating = True
For i = 1 To UBound(ArrTxt)
  MsgBox ArrTxt(i)
Next
End Sub