' решение для https://www.sql.ru/forum/actualutils.aspx?action=gotomsg&tid=1054045&msg=15001947
' использование: 
'  сохранить скрипт в удобное место
'  закрыть все экземпляры WORD
'  в проводнике перетащить обрабатываемый файл на файл скрипта
'  новые файлы будут созданы в папке с обрабатываемым файлом

option explicit

const wdFindContinue = 1
const pattern = "<TC *<}}}>"

dim w, d, dnew, a
dim name, path_save

set a = wscript.arguments
if checkArg(a) then wscript.quit 0
a = a(0)
path_save = left(a, instrrev(a,"\"))

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.saveas path_save & "TC_" & 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

const wdFindContinue = 1
const pattern = "<TC *Finish>"

option explicit

const wdFindContinue = 1
const pattern = "<TC *Finish>"

dim w, d, dnew, a
dim name, path_save

set a = wscript.arguments
if checkArg(a) then wscript.quit 0
a = a(0)
path_save = left(a, instrrev(a,"\"))

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.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