Option Explicit

Const wdFindContinue = 1
Const pattern = "<Отчет *<[0-2][0-9].[0-3][0-9].20[0-9][0-9]>"

Dim w, d, dnew, a
Dim name, path_save
Dim myStoryRange

Set a = wscript.arguments
If checkArg(a) Then wscript.Quit 0
a = a(0)
path_save = Left(a, InStrRev(a, "\"))
'20
Set w = CreateObject("word.application")
Set d = w.documents.Add(a)

With w.Selection.Find
    .clearformatting
    .Text = pattern
    .Forward = True
    .matchwildcards = True
    .wrap = wdFindContinue
    
    Do While .Execute
        w.Selection.Copy
        name = getName(w.Selection)
        Set dnew = w.documents.Add
        dnew.Content.Paste
        dnew.Paragraphs.Format.SpaceAfter = 0
        dnew.Content.Font.name = "Courier New"
  For Each myStoryRange In dnew.StoryRanges
  'Если нужны одинаковые параметры для всего текста:
   'myStoryRange.Font.Name = "Courier New"
  'Если для основного текста нужен один шрифт, а для сносок другой:
   Select Case myStoryRange.StoryType
    Case 1
     myStoryRange.Font.Name = "Courier New"
    Case 2
     With myStoryRange
      .Font.Name = "Calibri"
      .Font.Size = 12
      .ParagraphFormat.SpaceBefore = 0
      .ParagraphFormat.SpaceAfter = 6
      .ParagraphFormat.LineSpacing = w.LinesToPoints(1)
     End With
   End Select
  Next
        With dnew.Sections
            .PageSetup.LeftMargin = 56
        End With
        dnew.SaveAs path_save & "report_" & name & ".doc"
        dnew.Close False
    Loop
End With

Set dnew = Nothing
d.Close False
Set d = Nothing
w.Quit
Set w = Nothing
wscript.echo "Готово."
wscript.Quit 0
' ------------------------------------------
Function checkArg(p)
    If p.Count <> 1 Then
        wscript.echo "Неправильное число параметров." & vbLf & "Нужен 1. Есть " & p.Count & "."
        checkArg = 1
    End If
End Function
' ------------------------------------------
Function getName(sel)
    Const ILLEGAL = "\/:*?""<>|", R = "#"
    Dim s, k, c
    s = Left(sel.Text, InStr(1, sel.Text, Chr(13)) - 1)
    s = Mid(s, InStr(1, s, " ") + 1)
    For k = 1 To Len(ILLEGAL)
        c = Mid(ILLEGAL, k, 1)
        If (InStr(1, s, c)) Then s = Replace(s, c, R)
    Next
    getName = s
End Function