---

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

    Dim dataObj As Object
    Dim clipText As String
    Dim linesArr As Variant
    Dim i As Long
    Dim lineText As String
    Dim numPart As String
    Dim textPart As String
    Dim matchPos As Long
    Dim numLines As Long

    ' 1. Получаем текст из буфера обмена
    On Error Resume Next
    Set dataObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' MSForms.DataObject
    If Err.Number <> 0 Then
        ' Пробуем другой способ для 64-битных версий
        On Error GoTo 0
        Set dataObj = CreateObject("MSForms.DataObject")
    End If
    On Error GoTo 0

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

    dataObj.GetFromClipboard
    clipText = dataObj.GetText

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

    ' 2. Разбиваем на строки (разделители: перевод строки)
    linesArr = Split(clipText, vbCrLf)
    If UBound(linesArr) < 0 Then
        ' Может быть только vbLf
        linesArr = Split(clipText, vbLf)
    End If

    ' Убираем возможную пустую последнюю строку
    numLines = UBound(linesArr) + 1
    If numLines > 0 Then
        If Len(Trim(linesArr(numLines - 1))) = 0 Then
            numLines = numLines - 1
        End If
    End If

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

    ' 3. Вставляем нужное количество строк ПЕРЕД активной ячейкой
    '    (сдвигаем старые данные вниз)
    Application.ScreenUpdating = False
    ActiveCell.Resize(numLines).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    ' 4. Заполняем ячейки: столбец A (или активный столбец) — номер, следующий столбец — текст
    For i = 0 To numLines - 1
        lineText = linesArr(i)
        ' Ищем номер в начале строки: последовательность цифр, точка и пробел
        matchPos = 0
        ' Паттерн: цифры, точка, пробел
        ' Ищем первый символ, не являющийся цифрой, точкой или пробелом
        Dim j As Long
        For j = 1 To Len(lineText)
            If Not IsNumeric(Mid(lineText, j, 1)) And Mid(lineText, j, 1) <> "." And Mid(lineText, j, 1) <> " " Then
                Exit For
            End If
        Next j
        If j > 1 Then
            ' Считаем, что номер заканчивается пробелом после точки
            Dim dotPos As Long
            dotPos = InStr(lineText, ". ")
            If dotPos > 0 Then
                ' Проверяем, что до точки только цифры
                If IsNumeric(Left(lineText, dotPos - 1)) Then
                    numPart = Left(lineText, dotPos + 1) ' "1. "
                    textPart = Trim(Mid(lineText, dotPos + 2))
                Else
                    numPart = ""
                    textPart = lineText
                End If
            Else
                numPart = ""
                textPart = lineText
            End If
        Else
            numPart = ""
            textPart = lineText
        End If

        ' Записываем в ячейки
        ActiveCell.Offset(i, 0).Value = numPart
        ActiveCell.Offset(i, 1).Value = textPart
    Next i

    ' 5. Автоподбор ширины столбцов, если надо (можно убрать)
    ' ActiveCell.EntireColumn.AutoFit
    ' ActiveCell.Offset(0, 1).EntireColumn.AutoFit

    Application.ScreenUpdating = True

    ' ==== Завершаем запись отмены ====
    undoRec.EndCustomRecord
    ' ================================
End Sub