---

Sub ВставитьТекстСНумерацией()
    ' ==== Единая запись отмены ====
    Dim undoRec As Object
    On Error Resume Next
    Set undoRec = Application.UndoRecord
    On Error GoTo 0
    If Not undoRec Is Nothing Then
        undoRec.StartCustomRecord "Вставить текст с нумерацией"
    End If

    Dim dataObj As Object
    Dim clipText As String
    Dim lines() As String
    Dim n As Long
    Dim i As Long
    Dim ws As Worksheet
    Dim r0 As Long, c0 As Long
    Dim rngData As Range

    ' 1. Получить текст из буфера обмена
    On Error Resume Next
    Set dataObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    On Error GoTo 0
    If dataObj Is Nothing Then
        MsgBox "Не удалось получить доступ к буферу обмена."
        If Not undoRec Is Nothing Then undoRec.EndCustomRecord
        Exit Sub
    End If
    dataObj.GetFromClipboard
    clipText = dataObj.GetText
    If Len(Trim(clipText)) = 0 Then
        MsgBox "Буфер обмена пуст или содержит не текст."
        If Not undoRec Is Nothing Then undoRec.EndCustomRecord
        Exit Sub
    End If

    ' 2. Разбить на строки (поддерживает vbCrLf, vbLf, vbCr)
    clipText = Replace(clipText, vbCrLf, vbLf)
    clipText = Replace(clipText, vbCr, vbLf)
    lines = Split(clipText, vbLf)
    ' Удалить пустые строки в конце
    Do While UBound(lines) >= 0 And Trim(lines(UBound(lines))) = ""
        ReDim Preserve lines(UBound(lines) - 1)
    Loop
    n = UBound(lines) + 1
    If n = 0 Then
        MsgBox "Не найдено ни одной непустой строки."
        If Not undoRec Is Nothing Then undoRec.EndCustomRecord
        Exit Sub
    End If

    Set ws = ActiveSheet
    r0 = ActiveCell.Row
    c0 = ActiveCell.Column

    Application.ScreenUpdating = False

    ' 3. Вставить недостающие строки ПЕРЕД активной ячейкой,
    '    чтобы не перезаписать существующие данные
    If n > 1 Then
        ' Диапазон строк, которые нужно вставить: со следующей строки до n-1
        ws.Range(ws.Rows(r0 + 1), ws.Rows(r0 + n - 1)).EntireRow.Insert Shift:=xlDown
    End If

    ' 4. Записать данные с нумерацией прямо в ячейки
    For i = 0 To n - 1
        If Len(Trim(lines(i))) > 0 Then
            lines(i) = StrConv(Trim(lines(i)), vbProperCase)
        End If
        ws.Cells(r0 + i, c0).Value = (i + 1) & ". " & lines(i)
    Next i

    ' 5. Очистить формат и задать шрифт Times New Roman, 11
    Set rngData = ws.Range(ws.Cells(r0, c0), ws.Cells(r0 + n - 1, c0))
    rngData.ClearFormats
    With rngData.Font
        .Name = "Times New Roman"
        .Size = 11
    End With

    ' 6. Выделить первую ячейку с данными
    ws.Cells(r0, c0).Activate

    Application.ScreenUpdating = True

    If Not undoRec Is Nothing Then undoRec.EndCustomRecord
    MsgBox "Вставлено " & n & " строк(и) с нумерацией."
End Sub