Хранить всю информацию между жирным шрифтом предложения как элементы массива, Word VBA

Question

Я новичок в VBA и пытаюсь создать массив из 400-страничного документа в формате VBA из содержимого главы.Каждый элемент массива должен содержать все абзацы после полужирного заголовка главы до следующего заголовка главы.Это может быть лучше сформулировано как информация между заголовками глав.

Заголовок главы - это предложение, которое всегда выделено жирным шрифтом (и единственная часть документа, которая выделена жирным шрифтом).Информация, следующая за описанием главы, может иметь несколько абзацев и маркированную информацию, но в некоторых случаях она также может быть полностью пустой.В случае с пустым содержимым главы я хотел бы сохранить пустую запись какого-либо вида.

Мне удалось создать массив, каждый абзац которого был бы элементом массива.Однако, поскольку в каждой главе иногда имеется несколько абзацев и маркированных разделов, количество элементов в массиве превышает количество глав.Массив также хранит заголовки глав как их собственный элемент (я разобрался, как удалить заголовки из массива с помощью аналогичных сравнений).Я немного растерялся после того, как исследовал эту тему в течение нескольких часов сегодня.

Какой был бы способ хранения всей информации между «полужирными заголовками глав» в качестве элемента в массиве?

Большое спасибо за вашу помощь!

    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

Попробуйте что-нибудь на основе:

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

Answer 2

Приведенный ниже код основан на вашем утверждении, что только заголовки выделены жирным шрифтом.Если есть какой-либо текст, который не выделен жирным шрифтом перед первым заголовком, вам нужно будет добавить код, чтобы пропустить этот текст.Первоначально я написал это, используя 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 глав ниже.

Это жирный шрифттекст 1
Это не жирный текст1
Это не жирный текст
Это не жирный текст
Это жирный текст 2
Это не жирный текстtext2
Это не жирный текст
Это не жирный текст
Это жирный текст 3
Это не жирный текст3
Это не жирный текст
Это не жирный текст
Это не жирный текст
Это не жирный текст
Это жирный текст 4
Это не жирный текст4
Это не жирный тексттекст
Это не жирный текст
Это жирный текст 5
Это не жирный текст5
Это не жирный текст
Это не жирный текст
Это полужирный текст 6
Это не полужирный текст6
Это не полужирный текст
Это не полужирный текст

Answer 3

Если вы используете функцию «Заголовки» 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

ИСТОЧНИК: Поиск заголовка глав в файле слова и копирование отдельных абзацев в новый файл слова с помощью VBA