---

Sub ВставитьСписокИзWordСНумерацией_БезОтмены()
    Dim dataObj As Object
    Dim clipText As String
    Dim linesArr As Variant
    Dim i As Long, lineText As String, numPart As String, textPart As String
    Dim dotPos As Long, numLines As Long

    ' --- 1. Читаем буфер обмена ---
    On Error Resume Next
    Set dataObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    If Err.Number <> 0 Then
        On Error GoTo 0
        Set dataObj = CreateObject("MSForms.DataObject")
    End If
    On Error GoTo 0

    If dataObj Is Nothing Then
        MsgBox "Не удалось получить доступ к буферу обмена.", vbExclamation
        Exit Sub
    End If

    dataObj.GetFromClipboard
    clipText = dataObj.GetText

    If Len(Trim(clipText)) = 0 Then
        MsgBox "Буфер обмена пуст или содержит не текст.", vbInformation
        Exit Sub
    End If

    ' --- 2. Разбиваем на строки ---
    linesArr = Split(clipText, vbCrLf)
    If UBound(linesArr) < 0 Then linesArr = Split(clipText, vbLf)

    numLines = UBound(linesArr) + 1
    If numLines > 0 Then
        If Len(Trim(linesArr(numLines - 1))) = 0 Then numLines = numLines - 1
    End If

    If numLines = 0 Then
        MsgBox "Не найдено ни одной строки текста.", vbInformation
        Exit Sub
    End If

    ' --- 3. Вставляем строки ---
    Application.ScreenUpdating = False
    ActiveCell.Resize(numLines).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    ' --- 4. Заполняем два столбца ---
    For i = 0 To numLines - 1
        lineText = linesArr(i)
        dotPos = InStr(lineText, ". ")
        If dotPos > 0 And IsNumeric(Left(lineText, dotPos - 1)) Then
            numPart = Left(lineText, dotPos + 1)
            textPart = Trim(Mid(lineText, dotPos + 2))
        Else
            numPart = ""
            textPart = lineText
        End If
        ActiveCell.Offset(i, 0).Value = numPart
        ActiveCell.Offset(i, 1).Value = textPart
    Next i

    Application.ScreenUpdating = True
End Sub