[Iska]

sergey-pskov, цитирование осуществляется тэгом «quote».

Мне нужен именно макрос... В моем случае "нумерованный список" не подходит... »

Ясно. Тогда пробуйте так:

читать дальше »

Код:

Option Explicit

Sub AddNextNumber()
    Const boolReNumberNext As Boolean = True
    
    Dim arrLines() As String
    Dim i As Long
    
    Dim lngNextNumber As Long
    Dim retValue As String
    
    Dim objParagraph As Paragraph
    Dim objRange As Range
    
    
    Selection.Collapse Direction:=wdCollapseStart

    arrLines = Split(ActiveDocument.Range(ActiveDocument.Range.Start, Selection.Range.Start).Text, vbCr)
    
    lngNextNumber = 0
    
    For i = UBound(arrLines) To LBound(arrLines) Step -1
        If Left(arrLines(i), 1) = "№" Then
            lngNextNumber = CLng(Mid(arrLines(i), 2))
            
            Exit For
        End If
    Next
    
    retValue = InputBox("Введите очередной номер:", "Очередной номер", lngNextNumber + 1)
    
    If retValue <> "" Then
        With Selection
            .InsertParagraph
            .InsertAfter "№" & retValue
            
            .Collapse Direction:=wdCollapseEnd
            .InsertParagraph
            
            .Collapse Direction:=wdCollapseEnd
        End With
        
        If boolReNumberNext Then ' Перенумеровать все нижеследующие номера
            lngNextNumber = CLng(retValue) + 1
            
            For Each objParagraph In ActiveDocument.Range(Selection.Range.Start, ActiveDocument.Range.End).Paragraphs
                If objParagraph.Range.Characters.Item(1) = "№" Then
                    Set objRange = objParagraph.Range
                    
                    objRange.End = objRange.End - 1
                    objRange.Text = "№" & CStr(lngNextNumber)
                    
                    lngNextNumber = lngNextNumber + 1
                End If
            Next
        End If
    End If
End Sub

Прикреплён образец документа с данным макросом, внедрённой панелью инструментов и горячей клавишей.