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

下面的代码取决于您的陈述，即仅标题为粗体。如果在第一个标题之前有任何未加粗的文本，则您需要添加代码以跳过未加粗文本的文本。我最初使用Type来定义章节来编写此代码，但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章文档中签出了OK。

这是粗体文本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

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

3 个答案: