Store all information between bold sentences as array elements, Word VBA

Question

I am a VBA novice and I am trying to create an array from a 400 page word document in VBA made of chapter content. Each element of the array should contain all of the paragraphs following a bolded chapter title until the next chapter title. It may be better phrased as the information between chapter titles.

The chapter title is a sentence which is always bolded (and the only portion of the document which is bolded). The information following the chapter description may have multiple paragraphs and bulleted information but also may be completely empty in a few cases. In a case with empty chapter content, I would like a blank entry of some kind stored.

I've managed to make an array that has every paragraph as an array element. However, since there are sometimes multiple paragraphs and bulleted sections per chapter the amount of elements in the array is greater than the amount of chapters. The array also stores the chapter titles as their own element (I figured out how to remove titles from the array with like comparisons though). I am a bit lost after researching this subject for several hours today.

What would be a method to store all of the information between 'bolded chapter headings' as an element in an array?

Many thanks for your help!

    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

The code below relies on your statement that only headings are bolded. If there is any text that is not bolded before the first heading then you will need to add code to skip over this text unbolded text. I originally wrote this using a Type to define the Chapter but VBA kept giving me cryptic error messages so I reverted to an array.

The collection returned should contain arrays where index(1) is the heading text, and index(2) is the body text. The code was written with option explicit and raises no inspection issues with 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

The code above checked out OK on a the 6 chapter document below.

This is bold text 1
This is not bold text1
This is not bold text
This is not bold text
This is bold text 2
This is not bold text2
This is not bold text
This is not bold text
This is bold text 3
This is not bold text3
This is not bold text
This is not bold text
This is not bold text
This is not bold text
This is bold text 4
This is not bold text4
This is not bold text
This is not bold text
This is bold text 5
This is not bold text5
This is not bold text
This is not bold text
This is bold text 6
This is not bold text6
This is not bold text
This is not bold text

Answer 2

If you use the "Headings" feature of Word you can use those. Either "Heading 1" or "Heading 2" are objects that denote chapters and are already used by Word to build the table of contents.

This example uses "Heading 1" but you could use any other built-in Style:

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

SOURCE: Finding heading of chapters in word file and copying individual paragraphs to new word file with VBA

Answer 3

Try something based on:

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