---

Sub ВставитьТекстСНумерацией()
    Dim dataObj As Object
    Dim clipText As String
    Dim lines() As String
    Dim n As Long, i As Long
    Dim ws As Worksheet
    Dim r0 As Long, c0 As Long
    Dim rngData As Range

    ' 1. Получить текст из буфера обмена (универсальный способ)
    On Error Resume Next
    ' Пробуем MSForms.DataObject (доступен в большинстве версий)
    Set dataObj = CreateObject("Forms.DataObject.1")
    If dataObj Is Nothing Then
        ' Альтернативный вариант
        Set dataObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    End If
    If dataObj Is Nothing Then
        MsgBox "Не удалось обратиться к буферу обмена." & vbCrLf & _
               "Убедитесь, что данные скопированы (Ctrl+C) и попробуйте снова."
        Exit Sub
    End If
    dataObj.GetFromClipboard
    clipText = dataObj.GetText
    On Error GoTo 0

    If Len(Trim(clipText)) = 0 Then
        MsgBox "Буфер обмена пуст или содержит не текст."
        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 "Не найдено ни одной непустой строки."
        Exit Sub
    End If

    Set ws = ActiveSheet

    ' Проверка: не находится ли активная ячейка в структуре, куда нельзя вставить строки
    On Error Resume Next
    r0 = ActiveCell.Row
    c0 = ActiveCell.Column
    On Error GoTo 0

    If r0 = 0 Or c0 = 0 Then
        MsgBox "Выделите ячейку, куда нужно вставить данные."
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' 3. Вставить недостающие строки перед данными (если нужно больше одной)
    On Error Resume Next
    If n > 1 Then
        ' Вставляем n-1 строку ПОД активной ячейкой, сдвигая существующие данные вниз
        ws.Range(ws.Cells(r0 + 1, c0), ws.Cells(r0 + n - 1, c0)).EntireRow.Insert Shift:=xlDown
        If Err.Number <> 0 Then
            MsgBox "Ошибка при вставке строк. Возможно, лист защищён или недостаточно места."
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            Exit Sub
        End If
    End If
    On Error GoTo 0

    ' 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. Очистить форматирование и задать шрифт
    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.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "Вставлено " & n & " строк(и) с нумерацией."
End Sub