Форум по VBA и MS Office

Sub Main_SortSections()

    Dim docAct As Word.Document, sec As Word.Section
    Dim arrIndexes() As Long, i As Long
   
   
    '1. Vba-именование активного файла.
    Set docAct = ActiveDocument
   
    '2. Проверка, что в каждом разделе, в первом абзаце есть нужная фраза.
    For i = 1 To docAct.Sections.Count Step 1
        If Not docAct.Sections(i).Range.Paragraphs(1).Range.Text Like "*#Раздел*" Then
            docAct.Sections(i).Range.Paragraphs(1).Range.Select
            MsgBox "В этом абзаце (он выделен) нет фразы вида #Раздел.", vbExclamation
            Exit Sub
        End If
    Next i
   
    '3. Вставка разрыва раздела перед первым разделом, иначе после
        ' переносов первый раздел войдёт в состав другого раздела.
    docAct.Range(0, 0).InsertBreak Type:=wdSectionBreakNextPage

    '4. Извлечение порядковых номеров из фраз типа "1Раздел" в массив.
    Call pExtractIndexes(docAct, arrIndexes())
   
    '5. Вставка закладок в разделы. В эти закладки записываются порядковые номера разделов.
        ' Закладки нужны, т.к. после каждой перестановки расположение разделов будет изменяться.
    ' Первый раздел не учитывается, т.к. был вставлен макросом.
    For i = 2 To docAct.Sections.Count Step 1
        Set sec = docAct.Sections(i)
        docAct.Range(sec.Range.Start, sec.Range.Start).Bookmarks.Add Name:="Макрос_раздел_" & arrIndexes(i)
    Next i
   
    For i = docAct.Sections.Count To 2 Step -1
        '6. Перестановка раздела.
        docAct.Bookmarks("Макрос_раздел_" & i).Range.Sections(1).Range.Cut
        docAct.Range(0, 0).Paste
        '7. Удаление закладки, чтобы не засоряла файл.
        docAct.Bookmarks("Макрос_раздел_" & i).Delete
    Next i
   
    '8. Удаление последнего разрыва раздела. Его создал макрос в начале своей работы.
    docAct.Sections.Last.Range.Characters(1).Previous.Delete
   
    '9. Копирование любого небольшого фрагмента, чтобы после закрытия программы "Word"
        ' не было сообщения, что в буфере содержатся данные.
    docAct.Sections(1).Range.Characters(1).Copy
   
    '10. Сообщение.
    MsgBox "Макрос завершил работу.", vbInformation

End Sub

Private Sub pExtractIndexes(docAct As Word.Document, arrIndexes() As Long)
   
    ' Извлечение порядковых номеров из фраз типа "1Раздел" в массив.
   
    Dim sec As Word.Section, stri As String, i As Long, j As Long
   
   
    '1. Создание ячеек в массиве.
    ReDim arrIndexes(1 To docAct.Sections.Count)
   
    '2.
    ' Первый раздел создан макросом и пустой.
    For i = 2 To docAct.Sections.Count Step 1
        '1) Vba-именование раздела.
        Set sec = docAct.Sections(i)
        '2) Копирование первого абзаца в переменную.
        stri = sec.Range.Paragraphs(1).Range.Text
        '3) Извлечение фразы.
        ' Удаление текста до первой цифры.
            ' Спереди может быть разрыв страницs. Вероятно, ещё что-то может быть.
        For j = 1 To Len(stri) Step 1
            If Mid(stri, j, 1) Like "#" Then
                stri = Mid(stri, j)
                Exit For
            End If
        Next j
        '4) Извлечение числа. Корректировка порядкового номера с учётом того,
            ' что макрос создал в начале файла раздел.
        arrIndexes(i) = Val(stri) + 1
    Next i
   
End Sub

1
2
3
4
5
6
7
9
10
11
12
13
14
15
16
18
19
20
21
22
23