Как создать нумерованный список в Word

Sub Макрос1()
  With ListGalleries(wdNumberGallery).ListTemplates(2).ListLevels(1)
    .NumberFormat = "%1)"
    .TrailingCharacter = wdTrailingTab
    .NumberStyle = wdListNumberStyleArabic
    .NumberPosition = CentimetersToPoints(0.63)
    .Alignment = wdListLevelAlignLeft
    .TextPosition = CentimetersToPoints(1.27)
    .TabPosition = CentimetersToPoints(1.27)
    .ResetOnHigher = 0
    .StartAt = 1
    With .Font
      .Bold = wdUndefined
      .Italic = wdUndefined
      .StrikeThrough = wdUndefined
      .Subscript = wdUndefined
      .Superscript = wdUndefined
      .Shadow = wdUndefined
      .Outline = wdUndefined
      .Emboss = wdUndefined
      .Engrave = wdUndefined
      .AllCaps = wdUndefined
      .Hidden = wdUndefined
      .Underline = wdUndefined
      .Color = wdUndefined
      .Size = wdUndefined
      .Animation = wdUndefined
      .DoubleStrikeThrough = wdUndefined
      .Name = ""
    End With
    .LinkedStyle = ""
  End With
  ListGalleries(wdNumberGallery).ListTemplates(2).Name = ""
  Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
    wdNumberGallery).ListTemplates(2), ContinuePreviousList:=False, ApplyTo:= _
    wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
End Sub

Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
    wdNumberGallery).ListTemplates(2), ContinuePreviousList:=False, ApplyTo:= _
    wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior

With ListGalleries(wdNumberGallery).ListTemplates(2).ListLevels(1)

Sub AddNumberedList()
    'Основные переменные документа Word, описывающие соответственно
    'приложение, документ и диапазон в документе.
    Dim app As Word.Application, doc As Word.Document, rng As Word.Range
    'Переменные, необходимые для работы со списками.
    Dim lsg As Word.ListGallery   'Галерея шаблонов списков.
    Dim lst As Word.ListTemplate  'Шаблон списка.
    'Получаем доступ к приложению Word.
    Set app = GetObject(, "Word.Application")
    'Получаем доступ к активному документу в этом приложении.
    Set doc = app.ActiveDocument
    'Получаем галерею шаблонов нумерованных списков.
    Set lsg = app.ListGalleries(2)  'Всего есть 3 галереи:
                                    '1-я - маркированные списки.
                                    '2-я - нумерованные списки.
                                    '3-я - многоуровневые списки.
    'Из множества шаблонов нумерованных списков выбираем тот,
    'который с арабскими цифрами и скобкой ")".
    For Each lst In lsg.ListTemplates
        With lst.ListLevels(1)
            If Right(.NumberFormat, 1) = ")" And .NumberStyle = 0 Then Exit For
        End With
    Next lst
    'Получаем ссылку на диапазон всего документа.
    Set rng = doc.Range
    rng.Delete
    'Вставляем в документ текст, к которому будет применяться список.
    rng.Text = "пункт 1" & vbCrLf & "пункт 2" & vbCrLf & "пункт 3"
    'Определяем формат списка с помощью шаблона lst.
    rng.ListFormat.ApplyListTemplate lst
End Sub

    Set rng = Doc.Range
    'rng.Delete
    txt = ChrW(0)
 
    For i = 1 To 9
        i = i
        txt = txt & vbCrLf
    Next 'i
    rng.Text = txt '& ChrW(0)
    
    rng.ListFormat.ApplyListTemplate lst

    Set rng = Doc.Range
    rng.Delete
    For i = 1 To 9
        i = i
        txt = txt & ChrW(0) & vbCrLf
    Next i
    rng.Text = txt & ChrW(0)
 
    rng.ListFormat.ApplyListTemplate lst

'Option Explicit
 
Sub ВставитьПриложение()
'ПРИЛОЖЕНИЕ
On Error GoTo Err_DOC: If ActiveDocument.Name <> "" Then GoTo NoErr_DOC
Err_DOC: MvbErr (msg): Exit Sub
NoErr_DOC:
    'СООБЩЕНИЯ
    msg = "Продолжить, вставку ""Приложение""?"
    
    Set oRange = ActiveDocument.Range(Start:=Word.Selection.Start, End:=Word.Selection.Start)
    Dim oTable As Table, удалить As Table
    ширина = Fix(25 / 0.3528) 'для ширины столбца в мм
        
    'ПОДТВЕРЖДЕНИЕ
    If MvbYesNo(msg) = vbNo Then Exit Sub
    
    'УДАЛЯЕМ СТАРУЮ ТАБЛИЦУ
    If ActiveDocument.Tables.Count > 0 Then
        For Each удалить In Selection.Tables
        удалить.Delete
        Next удалить
    End If
 
    'ВСТАВЛЯЕМ НОВУЮ ТАБЛИЦУ
    Dim до As Byte: до = 6
    oRange.ParagraphFormat.Reset 'очищаем форматирование
    Set oTable = ActiveDocument.Tables.Add(oRange, 2, 2)
        oTable.Select
        oTable.Columns(1).Width = ширина 'первой колонки
        oTable.PreferredWidthType = 2    'ширина таблицы
        oTable.PreferredWidth = 100      'ширина таблицы
        Selection.Tables(1).Cell(1, 1).Range = "Приложение:"
        Selection.Tables(1).Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
        Selection.Tables(1).Cell(2, 1).Range = "Всего"
        Selection.Tables(1).Cell(2, 1).Range.ParagraphFormat.SpaceBefore = до
        Selection.Tables(1).Cell(2, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
        Selection.Tables(1).Cell(2, 2).Range = "? л."
        Selection.Tables(1).Cell(2, 2).Range.ParagraphFormat.SpaceBefore = до
        Selection.Tables(1).Cell(2, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
        Selection.Tables(1).Cell(1, 1).VerticalAlignment = wdCellAlignVerticalTop
        Selection.Tables(1).Cell(1, 2).VerticalAlignment = wdCellAlignVerticalTop
        Selection.ParagraphFormat.LineSpacing = LinesToPoints(1) 'междустрочный интервал
        Selection.ParagraphFormat.SpaceBefore = LinesToPoints(0) 'интервал перед параграфа  0.999 = 12
        Selection.ParagraphFormat.SpaceAfter = LinesToPoints(0)  'интервал после параграфа
 
    'ФОРМАТИРУЕМ ТАЛЛИЦЫ
    With oRange
        .Rows.WrapAroundText = False
        .Rows.Alignment = VerticalAlignment   'выравнивание на листе по левому краю поля
        .Rows.HeightRule = wdRowHeightAuto    'убирает галочку "Высота строки"
    End With
 
    'СОЗДАНИЕ И ОБРАБОТКА СПИСКА
    Dim lsg As Word.ListGallery, lst As Word.ListTemplate
        Set app = GetObject(, "Word.Application")
        Set Doc = Selection.Tables(1).Cell(1, 2)    'выделенная таблица
        Set lsg = app.ListGalleries(2)              'нумерованные списки.
        Set rng = Doc.Range
        
    For Each lst In lsg.ListTemplates
        With lst.ListLevels(1)
            If Right(.NumberFormat, 1) = "." And .NumberStyle = 0 Then Exit For '*
        End With
    Next lst
 
    'ОБРАБОТКА INPUTBOX
    Dim Message As String, Title As String, Default As String, MyValue As String
    Message = "Укажите колличество позиций"
    Title = MM
    Default = ""
    MyValue = InputBox(Message, Title, Default)
    rW = ChrW(8234)
    
    If MyValue = "" Then Exit Sub
    If MyValue = 0 Then Exit Sub
    If MyValue = 1 Then rng.Text = rW: GoTo d
    If MyValue = 2 Then MyValue = MyValue - 1
    If MyValue > 2 Then MyValue = MyValue - 1
    
    rng.Delete
    For i = 1 To MyValue 'если 10 - 1
        i = i: txt = txt & rW & vbCrLf
    Next i
    rng.Text = txt & rW
    
d:  'ФОРМАТИРУЕМ СПИСОК
    rng.ListFormat.ApplyListTemplate lst
    With lst.ListLevels(1)
            .Alignment = 2          'выравнивание по правому краю
            .NumberPosition = 20    'отступ слева
            .TextPosition = 20      'задает положение для второй линии
            .TrailingCharacter = 1  'символ после номера 0 - Tab, 1 - пробел
    End With
End Sub
 
Function MvbErr(msg) As String
'MsgBox ОШИБКА АКТИВНОСТИ ДОКУМЕНТА
    msg = "Необходимо открыть или создать документ!"
    Button = vbYes + 64
    Title = MM()
    MvbErr = MsgBox(msg, Button, Title)
End Function
 
Function MvbYesNo(ByVal msg) As String
'MsgBox ДА/НЕТ
    Button = vbYesNo + 64
    Title = MM
    MvbYesNo = MsgBox(msg, Button, Title)
End Function
 
Function MM() 'As String
    MM = "Вставить ""Приложение"""
End Function