---

Sub ВставитьСписокИз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 dotPos As Long
    Dim j As Long
    Dim 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)
    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
        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)    ' "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