Public Sub tryCreate()
    Dim pHyp As Hyperlink, newFileName As String
    Dim outPath As String
    Dim newDoc As Document
    outPath = ThisDocument.Path & "\funcs\"
    For Each pHyp In ThisDocument.Hyperlinks
        If InStr(pHyp.Address, "-функция") > 0 Then
            newFileName = Replace$(Replace$(pHyp.Range.Text, vbLf, ""), vbCr, "") & ".docx"
            Set newDoc = Application.Documents.Open(pHyp.Address)
            delTopParagraphs newDoc
            delLastParagraphs newDoc
            newDoc.SaveAs2 outPath & newFileName, WdSaveFormat.wdFormatXMLDocument, SaveFormsData:=False
            newDoc.Close
            'Stop
        End If
    Next
End Sub


Public Sub delTopParagraphs(ByVal inDoc As Document)
    Dim pPara As Paragraph, counter As Long, i As Long
    counter = 0
    For Each pPara In inDoc.Paragraphs
        If pPara.Format.OutlineLevel = wdOutlineLevel1 Then
            Exit For
        End If
        counter = counter + 1
    Next
    For i = counter To 1 Step -1
        inDoc.Paragraphs(i).Range.Delete
    Next
End Sub

Public Sub delLastParagraphs(ByVal inDoc As Document)
    Dim counter As Long, i As Long, pPara As Paragraph
    counter = 0
    For Each pPara In inDoc.Paragraphs
        counter = counter + 1
        If InStr(pPara.Range.Text, "Совершенствование навыков работы с Office") = 1 Then
            Exit For
        End If
    Next
    For i = inDoc.Paragraphs.Count To counter Step -1
        inDoc.Paragraphs(i).Range.Delete
    Next
End Sub

Public Sub dropEmptyHyperLinks()
    Dim pHyp As Hyperlink, sAddress As String
    
    For Each pHyp In ThisDocument.Hyperlinks
        sAddress = pHyp.Address
        If InStr(1, sAddress, "https://") = 0 Then
            pHyp.Delete
        End If
    Next
End Sub

Public Sub mergeDocs()
    Dim pHyp As Hyperlink, newFileName As String
    Dim inPath As String, newDoc As Document
    Dim nextDoc As Document, vCount As Long
    Dim pPara As Paragraph
    inPath = ThisDocument.Path & "\funcs\"
    Set newDoc = Application.Documents.Add
    For Each pHyp In ThisDocument.Hyperlinks
        If InStr(pHyp.Address, "-функция") > 0 Then
            newFileName = Replace$(Replace$(pHyp.Range.Text, vbLf, ""), vbCr, "") & ".docx"
            Set nextDoc = Application.Documents.Open(inPath & newFileName)
            Set pPara = newDoc.Paragraphs.Add
            nextDoc.Range.Copy
            pPara.Range.Paste
            nextDoc.Close False
            vCount = vCount + 1
            DoEvents
        End If
    Next
End Sub