Dim Flag_Number, Count_Simbol, Count_Level 

Flag_Number = false // флаг чисел
Count_Simbol = 0 // счетчик символов
Count_Level = 0 // счетчик уровня

Selection.HomeKey Unit:=wdStory // указатель в начало абзаца

If "Кол-во_символов_в_параграфе" < 3 then GoTo Last // не нуждается в обработке

For ... // Цикл для каждого знака текущего параграфа

 If Символ(i)<>[#, ".", " ", Tab] then GoTo LastOp // ВыходИзЦикла

 Inc(Count_Simbol)

 If Символ(i) = "#" then
   If Flag_Number = False then 
     Flag_Number = True
     Inc(Count_Level)
     Next // в начало цикла
   End If
 Else If Символ(i) = "." then
   Flag_Number =  false
 End If

End For

LastOp:
If Count_Simbol > 0 then Удалить первые символы в кол-ве Count_Simbol 
If Count_Level = 0 then Применить_Стиль "Обычный"
If Count_Level = 1 then Применить_Стиль "Раздел 1"
If Count_Level = 2 then Применить_Стиль "Раздел 2"
If Count_Level = 3 then Применить_Стиль "Раздел 3"

Александр Б. пишет:

Вы когда копируете макросы, включите русскую раскладку клавиатуры, чтобы не было абракадабры вместо русских комментариев.

Sub DelSpace()
' DelSpace Макрос
'
' УДАЛЯЕМ лишние пробелы (заменяем 2 и более пробелов одним)
'
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " {2;}"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.MoveRight Unit:=wdCharacter, Count:=1
'
'УДАЛЯЕМ пробел ПЕРЕД знаками пунктуации, ), % и концом абзаца
'
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " {1;}([.,:;!?%)^0013])"
.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.MoveLeft Unit:=wdCharacter, Count:=1
'
'УДАЛЯЕМ пробел ПОСЛЕ "(" и в начале абзаца (кроме первого)
'
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([(^0013])^0032"
.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.MoveLeft Unit:=wdCharacter, Count:=1
'
'ВСТАВЛЯЕМ пробел ПОСЛЕ знаков пунктуации, % и ), если после них нет пробела, цифры или конца абзаца
'
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([.,:;!?)%])([!^0032^00130123456789])"
.Replacement.Text = "1^00322"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.MoveLeft Unit:=wdCharacter, Count:=1
'
'ВСТАВЛЯЕМ пробел ПЕРЕД "(", если это не начало абзаца
'
Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([!^0032^0013])("
.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.MoveLeft Unit:=wdCharacter, Count:=1

End Sub

Alex_Gur пишет:

Исправил абракадабру.

карандаш пишет:

просьба подсказать как указывается путь

Александр Б. пишет:

Alex_Gur пишет:

Исправил абракадабру.

Я тоже хочу так научится…

Александр Б. пишет:

Мне не нравится, что вы задаете свои вопросы где хотите, выходя за рамки тем. Я, если честно, вообще за жесткую модерацию, поскольку это форум, где люди ищут информацию, а не чат какой-нибудь.

Call ReplaceSomeText("([Тт].)[^0032^s](к.)", "12") 'заменить "т. к." на "т.к."

Sub WildcardsReplaceProcedures()
'Несколько процедур поиска и замены с использованием подстановочных знаков

  ' 1) Ищем два и более пробелов подряд " {2;}" и заменяем на пробел " " (пробел можно записать как " " или "^0032").
  Call ReplaceSomeText("^0032{2;}", "^0032") '
    'Примечание - Искомый символ (пробел) задан перед фигурной скобкой, точка с запятой означает "и более" _
    Точка с запятой в операторах {n;} и {n;m} — это не просто точка с запятой, а так называемый List separator _
    (Разделитель элементов списка). В США это запятая, в России — точка с запятой. _
    Чтобы узнать, какой символ играет роль разделителя элементов списка в вашей конфигурации, _
    загляните в Control Panel | Regional Settings | Numbers | List separator _
    (Панель управления | Язык и стандарты | Числа | Разделитель элементов списка).
  
  ' 2) Удаляем один и более пробелов ПЕРЕД знаками пунктуации, перед символами ")", "%" и перед концом абзаца.
  Call ReplaceSomeText(" {1;}([.,:;!?%)^0013])", "1")
    'Примечание - Квадратные скобки означают ИЛИ, т.е. ищется любой из символов в кв. скобках. _
    Единица "1" означает порядковый номер выражения _
    (выражение это то, что заключается в круглые скобки; здесь выражение одно). _
    ^0013 это знак абзаца (код ASCII). _
    Вместо ) можно было бы написать просто курглую скобку ), в этом случае тоже работает.
  
  ' 3) Удаляем пробел ПОСЛЕ символа "(".
  Call ReplaceSomeText("( ", "(")
    'Внимание - Здесь я не хочу удалять пробел в начале абзаца, что записывается так: _
    .Text = "([(^0013])^0032" _
    .Replacement.Text = "1" _
    Это удалило бы пробел в начале абзацев, кроме первого. _
    Причина в том, что я прочитал в интеренете следующее сообщение: _
      "...впечатываем в поле "Найти" ^0013^0032{1;} в поле "Заменить на" ^0013 и в результате _
      удаляется любое количество пробелов в начале абзаца. _
      Но есть одна проблема: если к абзацам применены разные стили, то стиль предшествующего абзаца _
      заменяется на стиль последующего." _
    Пробел в начале абзацев я удалю другими способами (кстати, в начале абзаца может потребоваться удалить _
    не только пробел, но и, например, "жесткий" номер заголовка 1.1.1 и табуляцию).
   
  ' 4) Вставляем пробел ПОСЛЕ знаков пунктуации и после ")", "%", если после них нет пробела, НЕРАЗРЫВНОГО_ПРОБЕЛА, _
    цифры или конца абзаца
'''  Call ReplaceSomeText("([.,:;!?)%])([!^0032^00130123456789])", "1^00322") 'вариант Карандаша
  Call ReplaceSomeText("([.,:;!?)%])([!^0032^s^00130-9])", "1^00322") 'мой вариант с неразрывным пробелом ^s
    'Внимание - Вставка пробела после точки не всегда нужна. Например: _
      "т.е." заменяется на "т. е.", _
      "т.к." на "т. к.", _
      "А.А. Бирюков" на "А. А. Бирюков" _
    Поэтому далее нужно удалить лишние вставленные пробелы _
    (либо, как вариант, можно просто убрать точку из квадратных скобок в текущей процедуре).
  
  ' 5) Вставляем пробел ПЕРЕД скобкой "(", если перед ней нет пробела ^0032 или неразрывного пробела ^s
  Call ReplaceSomeText("([!^0032^s])(", "1 (")
    ' Примечание - Восклицательный знак в [!^0032^s] означает, что символ не является пробелом или _
    неразрывным пробелом _
    ' Круглые скобки (выражение) тут обязательно нужны, чтобы не удалять символ найденный слева от "("
  
'''''''' Начало процедур удаления лишних вставленных пробелов

  ' Заменить выражение типа "А. А. Бирюков" на "А.А.^sБирюков" _
    (между буквами может быть пробел ^0032 или неразрывный пробел ^s)
  Call ReplaceSomeText("([А-ЯЁ].)[^0032^s]([А-ЯЁ].)[^0032^s]([А-ЯЁ])", "12^s3")

  Call ReplaceSomeText("([Тт].)[^0032^s](к.)", "12") 'заменить "т. к." на "т.к."
  Call ReplaceSomeText("([Тт].)[^0032^s](е.)", "12") 'заменить "т. е." на "т.е."
  Call ReplaceSomeText("())[^0032^s](.)", "12") 'заменить ") ." на ")."
  
' *** ДОБАВЬТЕ ДОПОЛНИТЕЛЬНЫЕ ПРОЦЕДУРЫ ReplaceSomeText ДЛЯ ИСПРАВЛЕНИЯ ВСЕХ ИСКЛЮЧЕНИЙ ***
  
'''''''' Конец процедур удаления лишних вставленных пробелов
  
End Sub

Sub ReplaceSomeText(s1 As String, s2 As String, Optional blnWildcards As Boolean = True)
'Найти и заменить некий текст
'Ищет в текущем выделении фрагменты текста s1 и заменяет их на s2
'blnWildcards - необязательный агрумент, если не указан, то равен True, и подстановочные знаки включены.

  Selection.Find.ClearFormatting
  Selection.Find.Replacement.ClearFormatting
  With Selection.Find
    .Text = s1 'искомый текст
    .Replacement.Text = s2 'текст для замены
    .Forward = True
    .Wrap = wdFindStop 'в конце останавливаем поиск без переспросов
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchWildcards = blnWildcards 'подстановочные знаки включены (True) или отключены (False)
  End With
  Selection.Find.Execute Replace:=wdReplaceAll
  
End Sub

Sub X_TempMacro()
' Очистка выделенного текста от "мусора"

Dim x1, x2
  x1 = Selection.Range.Start 'левая граница выделения
  x2 = Selection.Range.End 'правая граница выделения
  If x1 = x2 Then Exit Sub 'если границы совпадают, то завершаем процедуру _
    (это защита от дурака, чтобы случайно не очистить весь документ целиком)

  Application.ScreenUpdating = False 'отключаем обновление экрана _
    (для увеличения скорости выполнения замен)

  'Несколько процедур поиска и замены, с использованием подстановочных знаков
  Call WildcardsReplaceProcedures
  
  Application.ScreenUpdating = True 'включаем обновление экрана
  
' *** НИЖЕ ДОБАВЛЮ ПРОЦЕДУРУ ОБРАБОТКИ НАЧАЛ АБЗАЦЕВ ***
 
''переходим в начало абзаца
'Dim oRng As Range
'  Set oRng = Selection.Paragraphs(1).Range
'  oRng.Collapse wdCollapseStart
'  oRng.Select
'
''выделяем один символ в начале абзаца
'  Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'  If Selection.Text = " " Then
'    Selection.Delete Unit:=wdCharacter, Count:=1 'если это пробел, то удаляем
'  Else
'    Selection.MoveLeft Unit:=wdCharacter, Count:=1 'иначе, влево на один
'  End If
  
End Sub

    Public Const отступ As Single = 0.95

    Sub Вычитка_списков()

        Dim j As Object
        Dim p As Object
        Dim i, i2 As Integer 'только для строки состояния

        'запоминаем количество списков в документе
        i2 = Application.ActiveDocument.Lists.Count

        'для каждого списка
        For Each j In Application.ActiveDocument.Lists

            'счётчик
            i += 1

            'строка состояния
            Application.StatusBar = "Вычитка списков: " & i & " из " & i2

            'для каждого элемента списка
            For Each p In j.ListParagraphs

                'выделить маркировку
                p.Range.Paragraphs(1).SelectNumber()

                'настройка шрифта
                With Application.Selection.Font

                    .Size = 14
                    .Name = "Times New Roman"
                    .Bold = False

                End With

            Next p

            'настройка параграфа
            With j.Range.ParagraphFormat

                'выступ
                .LeftIndent = Application.CentimetersToPoints(отступ)

                'отступ
                .FirstLineIndent = Application.CentimetersToPoints(-отступ)

                'правый выступ
                .RightIndent = Application.CentimetersToPoints(0)

                'табулятор
                .TabStops.ClearAll() 'если в обрабатываемом списке табуляторы имеют разные значения, возникает ошибка. Поэтому я их удаляю, чтобы задать заново единое значение.
                .TabStops(Application.CentimetersToPoints(отступ)).Position = Application.CentimetersToPoints(отступ)

            End With

        Next j

    End Sub

Sub LoadTemplate()
   ActiveDocument.CopyStylesFromTemplate (Environ("HOMEPATH") & "Documents!СтилиДоговора1.docx")
End Sub

Sub reNumber()
'
'проверка отсутствие выделения
If Selection.Type <> 1 Then
    MsgBox "Просто установите курсор внутри абзаца, который хотите преобразовать", 64
    Exit Sub
End If
'
'проверка наличия нужных стилей (чтобы не было ошибки применения несуществующего стиля)
Dim p As Style, MyStyleIs As Boolean
    
MyStyleIs = False
For i = 1 To ActiveDocument.Styles.Count ' так почему-то быстрее, чем с конца
    Set p = ActiveDocument.Styles(i)
    If Left$(p.NameLocal, 1) = "." Then
        MyStyleIs = True
        Exit For
    End If
Next i
If Not MyStyleIs Then LoadTemplate ' загрузка стилей, если они не нашлись
'
' если уже есть нумерация многоуровневыми стилями
If Selection.Range.ListFormat.ListType = wdListOutlineNumbering Then
    Lev = Selection.Range.ListFormat.ListLevelNumber
    Selection.Expand wdParagraph
    Select Case Lev
      Case 1
        Selection.Style = ActiveDocument.Styles(".Раздел 1")
      Case 2
        Selection.Style = ActiveDocument.Styles(".Раздел 2")
      Case 3
        Selection.Style = ActiveDocument.Styles(".Раздел 3")
    End Select
    Selection.Collapse
    Selection.MoveDown Unit:=wdParagraph, Count:=1
    Exit Sub
End If
'
' если обычный текст с/без нумерации в начале абзаца вручную
Dim ch As String, Flag_Number As Boolean, Count_Level, Count_Simbol As Integer, r

Flag_Number = False
Count_Level = 0
Count_Simbol = 0

With Selection
    .StartOf Unit:=wdParagraph, Extend:=wdMove
    .Expand wdParagraph
    n = .Characters.Count
    
    For i = 1 To n
    
        ch = .Characters(i)
        If (ch Like "[!0-9. ]") And (ch <> Chr(9)) Then Exit For
        Count_Simbol = Count_Simbol + 1
    
        If ch Like "[0-9]" Then
            If Flag_Number = False Then
                Flag_Number = True
                Count_Level = Count_Level + 1
                'Next '// в начало цикла
            End If
        ElseIf ch = "." Then
            Flag_Number = False
        End If
    
    Next i
  
End With

Selection.End = Selection.Start + Count_Simbol
If Count_Simbol > 0 Then Selection.Delete
Selection.Expand wdParagraph
Select Case Count_Level
    Case 0
        Selection.Style = ActiveDocument.Styles(".стандартный")
    Case 1
        Selection.Style = ActiveDocument.Styles(".Раздел 1")
    Case 2
        Selection.Style = ActiveDocument.Styles(".Раздел 2")
    Case 3
        Selection.Style = ActiveDocument.Styles(".Раздел 3")
End Select
'Selection.Collapse
Selection.MoveDown Unit:=wdParagraph, Count:=1 ' автоматически переходим к следующему абзацу (чтобы не надо было жать Ctrl+СтрелкаВниз)
End Sub