Как выбирать нужные значения из заголовков?

Sub Procedure_2()
    Dim rngSearch As Word.Range
    Dim myFind As Word.Find
    Set rngSearch = ActiveDocument.Range(Start:=0, End:=0)
    Set myFind = rngSearch.Find
    With myFind
        .Text = "модель"
        .Style = "Заголовок 1"
        .MatchWildcards = True
        Do While .Execute = True
            rngSearch.Collapse Direction:=wdCollapseEnd
            .Text = "<*>"
            .Execute
            Debug.Print rngSearch.Text
            rngSearch.Collapse Direction:=wdCollapseEnd
            .Text = "модель"
        Loop
    End With
End Sub

'Процедура ищет в тексте документа диапазоны, выделенные стилем "Заголовок 1".
'Для каждого найденного диапазона, если текст диапазона соответствует шаблону
'регулярного выражения, процедура выводит номер модели.
Sub FindModelNumbers()
   Dim rgX As Object, sbM As Object
   Dim s As String, n As Long
   Set rgX = CreateObject("VBScript.RegExp")
   rgX.IgnoreCase = True
   rgX.Pattern = "(?:^|^.*[^А-ЯЁ])МОДЕЛЬ(?:(\d+)|[^А-ЯЁ]\D*(\d+)).*$"
   With ActiveDocument.Range
      .Find.Style = "Заголовок 1"
      Do While .Find.Execute = True
         s = Replace(.Text, vbCr, "")
         If Len(s) > 0 Then
            .Collapse Direction:=wdCollapseEnd
            If rgX.Test(s) Then
               Set sbM = rgX.Execute(s)(0).SubMatches
               Debug.Print s & ": номер - " & sbM(0) & sbM(1)
            Else
               Debug.Print s & ": не соответствует шаблону."
            End If
         Else
            Exit Do
         End If
      Loop
   End With
End Sub

Sub Model¹()
'
' Model¹ Ìàêðîñ
'
'
    Selection.Copy
    Selection.MoveDown Unit:=wdLine, Count:=5
    Selection.InsertRowsBelow 1
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.PasteAndFormat (wdFormatPlainText)
    Selection.MoveUp Unit:=wdLine, Count:=7
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=6
    Selection.MoveRight Unit:=wdCharacter, Count:=7, Extend:=wdExtend
    Selection.Copy
    Selection.MoveDown Unit:=wdLine, Count:=6
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.PasteAndFormat (wdFormatPlainText)
    Selection.MoveDown Unit:=wdLine, Count:=43
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=14
    Selection.MoveRight Unit:=wdCharacter, Count:=6, Extend:=wdExtend
    Selection.Copy
End Sub

Sub InsertModelNumbers()
    Dim rgX As Object
    Dim modN As Collection
    Dim d As Document
    Dim tbl As Table
    Dim i As Long
    Set rgX = CreateObject("VBScript.RegExp")
    Set modN = New Collection
    rgX.Pattern = "^.*модель.((?:-|\d)+).*$"
    Set d = ActiveDocument
    With d.Range
        .Find.Style = "Заголовок для моделей вагонов"
        Do While .Find.Execute = True
            If rgX.Test(.Text) Then modN.Add rgX.Replace(.Text, "$1")
            .Collapse Direction:=wdCollapseEnd
        Loop
    End With
    For Each tbl In d.Tables
        i = i + 1
        tbl.Rows.Add tbl.Rows(2)
        tbl.Rows(2).Cells(1).Range.Text = "Модель"
        tbl.Rows(2).Cells(2).Range.Text = modN(i)
    Next tbl
End Sub

rgX.Pattern = "^.*модель.((?:-|\d)+).*$"