Извлечь оглавления из нескольких документов в один новый

Private Sub CommandButton1_Click()
curr_dir$ = getpath.SelDir(0)               'открытие диалога общения с пользователем
    Dim str As String
    Dim odocum1 As Document
        
  '  find_str = TextBox1.Text
        
    If curr_dir$ <> "" Then
   '     Me.ListBox1.Clear
        cF$ = Dir$(curr_dir$ + "\*.doc")
           
        Do
            If cF$ = "" Then Exit Do
            str = curr_dir$ + "\" + cF$
              
            Set odocum1 = Word.Application.Documents.Open(str, , False) 'открытие документа
            
            
            Dim r
Set r = ActiveDocument.Range
With r.Find
    .ClearFormatting
    .Text = "СОДЕРЖАНИЕ*Конец"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
        ActiveDocument.Range(r.Start + 4, r.End - 4).Select
        Selection.Copy
        Set odocum1 = Word.Application.Documents.Open("H:\проект\sapronova.docm", , False) 'открытие документа
        Selection.MoveDown Unit:=wdLine, Count:=1
        Selection.PasteAndFormat (wdPasteDefault)
        Selection.PasteAndFormat (wdPasteDefault)
        Selection.PasteAndFormat (wdPasteDefault)
    Else
        MsgBox "Текст не найден!", vbExclamation
    End If
End With
           ' If OptionButton1.Value = True Then
            
          '  Dim TestArray() As String
           ' Dim sum As Integer
           ' TestArray() = Split(find_str)
           ' For i = 0 To UBound(TestArray)
          '  MsgBox (TestArray(i))
           ' a = Find(TestArray(i))
           ' sum = sum + q
           ' Next
           ' If sum = UBound(TestArray) + 1 Then
            '    Me.ListBox1.AddItem cF$ & "   Есть совпадение"
             ' Else
              '  Me.ListBox1.AddItem cF$ & "   Нет совпадений"
             ' End If
           ' MsgBox (UBound(TestArray))
                cF$ = Dir$()
           ' End If
            
            'If OptionButton2.Value = True Then
                
             '   Dim TestArray1() As String
          '  Dim sum1 As Integer
          '  TestArray1() = Split(find_str)
          '  For i = 0 To UBound(TestArray1)
          '  MsgBox (TestArray(i))
          '  a = Find(TestArray1(i))
          '  sum1 = sum1 + q
          '  Next
          '  If sum1 > 0 Then
          '      Me.ListBox1.AddItem cF$ & "   Есть совпадение"
          '    Else
          '      Me.ListBox1.AddItem cF$ & "   Нет совпадений"
          '    End If
           ' MsgBox (UBound(TestArray))
           '     cF$ = Dir$()
           ' End If
            
          '  If OptionButton2.Value = False & OptionButton1.Value = False Then
          '  a = Find(find_str)
          '    If q = 1 Then
           ''     Me.ListBox1.AddItem cF$ & "   Есть совпадение"
            '  Else
            '    Me.ListBox1.AddItem cF$ & "   Нет совпадений"
            '  End If
              
             ' cF$ = Dir$()
           ' End If
            
           
           Loop
                      
           
        End If
End Sub

.Text = "СОДЕРЖАНИЕ*Конец"