---

Sub ВставитьИзExcelПрямо()
    Dim xlApp As Object
    Dim xlSel As Object
    Dim cell As Object
    Dim txt As String
    Dim i As Long
    Dim startPos As Long
    Dim colParas As Collection
    Dim para As Paragraph
    Dim rngFirst As Range
    Dim undoRec As UndoRecord
    
    ' ==== Единая отмена ====
    Set undoRec = Application.UndoRecord
    undoRec.StartCustomRecord "Вставить из Excel"
    
    ' 1. Подключиться к открытому Excel
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    On Error GoTo 0
    If xlApp Is Nothing Then
        MsgBox "Excel не запущен. Откройте файл и выделите нужные ячейки."
        undoRec.EndCustomRecord
        Exit Sub
    End If
    
    ' 2. Получить выделенный диапазон
    On Error Resume Next
    Set xlSel = xlApp.Selection
    On Error GoTo 0
    If xlSel Is Nothing Then
        MsgBox "Не удалось получить выделение в Excel."
        undoRec.EndCustomRecord
        Exit Sub
    End If
    
    ' 3. Собрать текст из ячеек столбиком
    txt = ""
    For Each cell In xlSel
        txt = txt & cell.Text & vbCrLf
    Next cell
    
    ' 4. Вставить этот текст в Word на место курсора
    startPos = Selection.Start
    Selection.TypeText txt
    
    ' 5. Выделить только что вставленное
    Selection.SetRange Start:=startPos, End:=Selection.End
    
    ' 6. Очистка форматирования
    Selection.ClearFormatting
    Selection.ParagraphFormat.Reset
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
        .FirstLineIndent = 0
        .LeftIndent = 0
        .RightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
    End With
    
    ' 7. Шрифт
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 11
    End With
    
    ' 8. Заглавные буквы
    Selection.Range.Case = wdTitleWord
    
    ' 9. Сбор абзацев и нумерация
    Set colParas = New Collection
    For Each para In Selection.Range.Paragraphs
        If Len(para.Range.Text) > 1 Then
            colParas.Add para
        End If
    Next para
    
    If colParas.Count > 0 Then
        i = 1
        For Each para In colParas
            para.Range.InsertBefore i & ". "
            i = i + 1
        Next para
        Set rngFirst = colParas(1).Range.Duplicate
        rngFirst.InsertParagraphBefore  ' отступ сверху
    End If
    
    ' 10. Переход в конец и отступ снизу
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.TypeParagraph
    Selection.ClearFormatting
    Selection.ParagraphFormat.Reset
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
    End With
    
    Selection.Collapse Direction:=wdCollapseEnd
    undoRec.EndCustomRecord
End Sub