---

' ===== В САМОМ ВЕРХУ МОДУЛЯ (Personal.xlsb) =====
Private SavedRow As Long
Private SavedCol As Long
Private SavedNumLines As Long
Private SavedOldData As Variant
' =================================================

Sub ВставитьСписокИзWordСНумерацией()
    Dim dataObj As Object, clipText As String, linesArr As Variant
    Dim i As Long, lineText As String, numPart As String, textPart As String
    Dim dotPos As Long, numLines As Long
    Dim ws As Worksheet
    Dim rngBefore As Range
    Dim multiPart As Boolean
    Dim parts As Variant
    Dim cell2Text As String, cell3Text As String

    ' 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. Проверяем, есть ли табуляции (несколько ячеек)
    multiPart = (InStr(clipText, vbTab) > 0)
    cell2Text = ""
    cell3Text = ""

    If multiPart Then
        Dim tableRows As Variant
        tableRows = Split(clipText, vbCrLf)
        If UBound(tableRows) < 0 Then tableRows = Split(clipText, vbLf)

        ' Ищем первую непустую строку
        Dim rowText As String
        rowText = ""
        For i = 0 To UBound(tableRows)
            If Trim(tableRows(i)) <> "" Then
                rowText = tableRows(i)
                Exit For
            End If
        Next i

        ' Разбиваем строку по табуляции
        parts = Split(rowText, vbTab)
        If UBound(parts) >= 2 Then
            cell2Text = parts(1)
            If UBound(parts) >= 3 Then
                cell3Text = parts(2)
            End If
            ' Первая часть – убираем пустые строки
            clipText = parts(0)
        End If
    End If

    ' 3. Очищаем от пустых строк с помощью Collection (безопасно)
    Dim rawLines As Variant
    rawLines = Split(clipText, vbCrLf)
    If UBound(rawLines) < 0 Then rawLines = Split(clipText, vbLf)

    Dim colLines As New Collection
    Dim rawLine As Variant
    For Each rawLine In rawLines
        If Trim(CStr(rawLine)) <> "" Then
            colLines.Add CStr(rawLine)
        End If
    Next rawLine

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

    ' Переносим в массив linesArr
    numLines = colLines.Count
    ReDim linesArr(0 To numLines - 1)
    For i = 1 To numLines
        linesArr(i - 1) = colLines(i)
    Next i

    ' 4. Сохраняем состояние ячеек, которые будут затёрты
    Set ws = ActiveSheet
    SavedRow = ActiveCell.Row
    SavedCol = ActiveCell.Column
    SavedNumLines = numLines

    Set rngBefore = ws.Range(ws.Cells(SavedRow, SavedCol), ws.Cells(SavedRow + numLines - 1, SavedCol + 1))
    If Not rngBefore Is Nothing Then
        SavedOldData = rngBefore.Value
    Else
        SavedOldData = Empty
    End If

    ' 5. Вставляем строки (сдвиг вниз) и заполняем
    Application.ScreenUpdating = False
    ws.Rows(SavedRow & ":" & SavedRow + numLines - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    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

        With ws.Cells(SavedRow + i, SavedCol)
            .Value = numPart
            .Font.Bold = False
            .HorizontalAlignment = xlRight
        End With

        With ws.Cells(SavedRow + i, SavedCol + 1)
            .Value = textPart
            .Font.Bold = False
        End With

        ' Если есть вторая/третья ячейка – заполняем на каждой строке
        If multiPart Then
            ws.Cells(SavedRow + i, 5).Value = cell2Text  ' столбец E
            ws.Cells(SavedRow + i, 5).Font.Bold = False
            ws.Cells(SavedRow + i, 6).Value = cell3Text  ' столбец F
            ws.Cells(SavedRow + i, 6).Font.Bold = False
        End If
    Next i

    ' 6. Автоподбор высоты строк
    ws.Rows(SavedRow & ":" & SavedRow + numLines - 1).EntireRow.AutoFit

    ' 7. Удаление всех строк до следующей объединённой ячейки в столбцах C или D
    Dim lastInsertedRow As Long
    lastInsertedRow = SavedRow + numLines - 1

    Dim nextMergedRow As Long
    nextMergedRow = 0

    Dim r As Long
    For r = lastInsertedRow + 1 To lastInsertedRow + 1000
        If ws.Cells(r, 3).MergeCells Or ws.Cells(r, 4).MergeCells Then
            If ws.Cells(r, 3).MergeCells Then
                nextMergedRow = ws.Cells(r, 3).MergeArea.Row
            Else
                nextMergedRow = ws.Cells(r, 4).MergeArea.Row
            End If
            Exit For
        End If
    Next r

    If nextMergedRow > 0 Then
        Dim firstRowToDelete As Long, lastRowToDelete As Long
        firstRowToDelete = lastInsertedRow + 1
        lastRowToDelete = nextMergedRow - 1
        If lastRowToDelete >= firstRowToDelete Then
            ws.Rows(firstRowToDelete & ":" & lastRowToDelete).Delete Shift:=xlUp
        End If
    End If

    Application.ScreenUpdating = True
End Sub

Sub ОтменитьПоследнююВставкуСписка()
    If SavedNumLines <= 0 Then
        MsgBox "Нет данных для отмены последней вставки.", vbInformation
        Exit Sub
    End If

    Dim ws As Worksheet
    Set ws = ActiveSheet

    Application.ScreenUpdating = False

    ws.Rows(SavedRow & ":" & SavedRow + SavedNumLines - 1).Delete Shift:=xlUp

    If Not IsEmpty(SavedOldData) Then
        Dim rngRestore As Range
        Set rngRestore = ws.Range(ws.Cells(SavedRow, SavedCol), ws.Cells(SavedRow + SavedNumLines - 1, SavedCol + 1))
        rngRestore.Value = SavedOldData
    End If

    SavedNumLines = 0
    SavedOldData = Empty

    Application.ScreenUpdating = True
End Sub