Поиск фраз и создание из них заголовков

Sub MarkHeadings()
MarkHeadingsByKeywords "keywords_headings.doc*", "Heading 3"
End Sub

Sub MarkHeadingsByKeywords(Keyw_Doc As String, heading_stylename As String)
'Marks keyword-related paragraphs in the main document with definite syle
Dim kw As Variant
Dim para As Paragraph
Dim Main_Document As String
Dim Keyw_Document As String
Dim kwdoc_found As Boolean
Dim paratext As String
Dim ikw As Long
Dim pw_cnt As Long

'1. Check for the keywords file opened
Main_Document = ActiveDocument.Name
kwdoc_found = False
For Each doc In Documents
    If UCase$(doc.Name) Like UCase$(Keyw_Doc) Then
        kwdoc_found = True
        Keyw_Doc = doc.Name
    End If
Next doc
If kwdoc_found <> True Then
   MsgBox Keyw_Doc & " file is not loaded"
   GoTo e_MHBK
End If

'2. Prepare the keywords array
Documents(Keyw_Doc).Activate
kw = Split(Documents(Keyw_Doc).Range.text, Chr$(13))

'3. Scan the main file and shade the matching keywords.
Documents(Main_Document).Activate
Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst
For Each para In Documents(Main_Document).Paragraphs
    pwcnt = para.Range.Words.count
    If pw_cnt < 4 Then 'if a paragraph contains less than N words, it seems to be a heading
        paratext = para.Range.text
        For ikw = 0 To UBound(kw)
            next_kw = Trim$(CStr(kw(ikw)))
            If next_kw <> "" Then 'omit empty keywords
                If paratext Like next_kw Then
                    'Apply heading style to the paragraph
                    para.Range.Select
                    On Error Resume Next
                    para.style = Documents(Main_Document).Styles(heading_stylename)
                    On Error GoTo 0
                    GoTo mk_next_para
                End If
            End If
        Next ikw
    End If
mk_next_para:
Next
Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst
e_MHBK:
End Sub