Макрос. Приведение документа WORD к нужному виду - VBA

Формулировка задачи:

Всем доброго времени суток. Есть некий документ WORD написанный абы как. Необходимо макросом исправить в нем лишние/не достающие пробелы, абзацы пустые строки. Необходимо функционирование макроса в WORD 2007 (2013) С двойными и лишними пробелами смог побороться вот таким макросом.

Sub DeleteSpace()
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
 .Text = " {2;}"
 .Replacement.Text = " "
 .Forward = True
 .Wrap = wdFindAsk
 .Format = False
 .MatchCase = False
 .MatchWholeWord = False
 .MatchAllWordForms = False
 .MatchWildcards = True
End With
With Selection.Find
 .Text = " {1;}([.,:;\!\?])"
 .Replacement.Text = "\1"
 .Forward = True
 .Wrap = wdFindContinue
 .Format = False
 .MatchCase = False
 .MatchWholeWord = False
 .MatchAllWordForms = False
 .MatchSoundsLike = False
 .MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub

Хотелось бы в него добавить удаление пустых строк и установку необходимых пробелов после точек и запятых, а также установка пробелов перед открывающимися скобками. Прошу помочь. Файл для примера прилагаю.Характеристика .docx

Решение задачи: «Макрос. Приведение документа WORD к нужному виду»

textual
                            Листинг программы 
                        

                            Option Explicit
Sub Замена2()
Dim i As Variant
Dim arrText() As Variant
Dim xm(100), ym(100)
Dim x1 As Long
 
 
 x1 = x1 + 1: xm(x1) = "(.)([А-Я])": ym(x1) = "\1 \2" 'добавить пробел между точкой и следующим предложением
 x1 = x1 + 1: xm(x1) = "([А-Я].@)([А-Я])": ym(x1) = "\1 \2" 'добавить пробел между двумя ЗАГЛАВНЫМИ
 x1 = x1 + 1: xm(x1) = "([А-Я].@)([А-Я])": ym(x1) = "\1 \2" 'добавить пробел между двумя ЗАГЛАВНЫМИ для второй буквы
 x1 = x1 + 1: xm(x1) = "(,)(*)": ym(x1) = "\1 \2" 'добавить пробел между запятой и следующим словом
 x1 = x1 + 1: xm(x1) = "\(": ym(x1) = " (" 'добавить пробел перед открывающей скобкой
 x1 = x1 + 1: xm(x1) = "\)": ym(x1) = ") " 'добавить пробел после закрывающей скобки
 x1 = x1 + 1: xm(x1) = "\№": ym(x1) = "№ " 'добавить пробел после знака "№"
 'x1 = x1 + 1: xm(x1) = "\-": ym(x1) = " - " 'добавить пробел по сторонам знака "-"
 x1 = x1 + 1: xm(x1) = "(.) (^13)": ym(x1) = "\1\2" 'убрать пробелы между точкой и переходом на следующую строку
 x1 = x1 + 1: xm(x1) = "\( ": ym(x1) = "(" 'убрать пробел после открывающей скобкой
 x1 = x1 + 1: xm(x1) = " \)": ym(x1) = ")" 'убрать пробел перед закрывающей скобки
 x1 = x1 + 1: xm(x1) = "(*) @(.)": ym(x1) = "\1\2" 'убрать пробелы между словом и точкой
 x1 = x1 + 1: xm(x1) = "(*) @(,)": ym(x1) = "\1\2" 'убрать пробелы между словом и запятой
 x1 = x1 + 1: xm(x1) = "( ){2;}": ym(x1) = " " 'убрать повторяющиеся пробелы
 
Selection.WholeStory
 
For i = 1 To x1
 Debug.Print i, xm(i), "===="; ym(i)
 Selection.Find.ClearFormatting
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find
 .Text = xm(i)
 .Replacement.Text = ym(i)
 .Forward = True
 .Wrap = wdFindContinue
 .Format = False
 .MatchCase = False
 .MatchWholeWord = False
 .MatchWildcards = True
 .MatchSoundsLike = False
 .MatchAllWordForms = False
 End With
 Selection.Find.Execute Replace:=wdReplaceAll
Next
' Убрать пустые строки в конце документа
 ActiveDocument.Range(0, 0).Select
    Selection.EndKey wdStory
    On Error Resume Next
    Do
        If Selection.Previous.Text <> vbCr Then Exit Do
        Selection.TypeBackspace
    Loop
' Конец уборки строк
' Пусть будет указанный шрифт
Selection.WholeStory
Selection.Font.Name = "Times New Roman"
' Конец шрифта
End Sub
                        