---

Sub ВставитьИзExcelОформитьСписок()
    ' ==== Единая запись отмены ====
    Dim undoRec As UndoRecord
    Set undoRec = Application.UndoRecord
    undoRec.StartCustomRecord "Вставить и оформить список"
    ' ==============================

    Dim targetCell As Range
    Dim pasteRange As Range
    Dim lastCell As Range
    Dim cell As Range
    Dim i As Long

    ' Запоминаем активную ячейку (верхнюю левую для вставки)
    Set targetCell = ActiveCell

    ' 1. Проверяем буфер обмена
    If Application.CutCopyMode = False Then
        MsgBox "Буфер обмена пуст. Скопируйте ячейки в Excel."
        undoRec.EndCustomRecord
        Exit Sub
    End If

    ' 2. Вставляем только значения (без форматирования) начиная с targetCell
    On Error Resume Next
    targetCell.PasteSpecial Paste:=xlPasteValues
    If Err.Number <> 0 Then
        MsgBox "Ошибка вставки: " & Err.Description
        undoRec.EndCustomRecord
        Exit Sub
    End If
    On Error GoTo 0

    ' Определяем диапазон вставленных данных
    ' (предполагаем один столбец, данные вниз от targetCell)
    Set pasteRange = Range(targetCell, targetCell.End(xlDown))
    ' Если вставлено несколько столбцов — уточняем по последней ячейке
    If pasteRange.Columns.Count > 1 Then
        Set pasteRange = Range(targetCell, pasteRange.End(xlToRight))
    End If

    ' 3. Вставляем пустую строку сверху (сдвигаем данные вниз)
    targetCell.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    ' Теперь данные начинаются с targetCell.Offset(1)

    ' 4. Вставляем пустую строку снизу после последней строки данных
    Set lastCell = targetCell.Offset(1).End(xlDown)
    If lastCell.Row > targetCell.Offset(1).Row Then
        lastCell.Offset(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If

    ' 5. Нумерация, форматирование и заглавные буквы
    i = 1
    Set lastCell = targetCell.Offset(1).End(xlDown) ' обновляем после вставки нижней строки
    For Each cell In Range(targetCell.Offset(1), lastCell)
        ' Префикс "1. " и т.д.
        cell.Value = i & ". " & CStr(cell.Value)
        ' Первая буква каждого слова заглавная
        cell.Value = StrConv(cell.Value, vbProperCase)
        i = i + 1
    Next cell

    ' 6. Очищаем форматирование и задаём шрифт
    Range(targetCell.Offset(1), lastCell).ClearFormats
    With Range(targetCell.Offset(1), lastCell).Font
        .Name = "Times New Roman"
        .Size = 11
    End With

    ' 7. Снимаем выделение, переходим в начало
    targetCell.Select

    ' ==== Завершаем единую отмену ====
    undoRec.EndCustomRecord
    ' ===============================
End Sub