---

' ===== В САМОМ ВЕРХУ МОДУЛЯ (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, totalLines As Long
    Dim ws As Worksheet
    Dim rngBefore As Range

    ' 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)

    ' Убираем возможную пустую последнюю строку
    Dim ub As Long
    ub = UBound(linesArr)
    If ub >= 0 Then
        If Len(Trim(linesArr(ub))) = 0 Then
            ub = ub - 1
        End If
    End If
    If ub < 0 Then
        MsgBox "Не найдено ни одной строки текста.", vbInformation
        Exit Sub
    End If

    ' 3. Определяем заголовок и элементы
    Dim headerText As String
    headerText = linesArr(0)
    Dim itemLines() As String
    Dim numItems As Long
    If ub >= 1 Then
        numItems = ub ' строки с 1 по ub – элементы
        ReDim itemLines(0 To numItems - 1)
        For i = 0 To numItems - 1
            itemLines(i) = linesArr(i + 1)
        Next i
    Else
        numItems = 0
    End If

    totalLines = 1 + numItems

    ' 4. Сохраняем состояние ячеек C:F
    Set ws = ActiveSheet
    SavedRow = ActiveCell.Row
    SavedCol = 3   ' столбец C
    SavedNumLines = totalLines

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

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

    ' 6. Вставляем заголовок: объединяем C и D
    With ws.Range(ws.Cells(SavedRow, 3), ws.Cells(SavedRow, 4))
        .Merge
        .Value = headerText
        .Font.Bold = False
    End With

    ' 7. Вставляем элементы списка
    For i = 0 To numItems - 1
        lineText = itemLines(i)

        ' Разбиваем строку по табуляции
        Dim parts As Variant
        parts = Split(lineText, vbTab)
        ' Проверка на случай пустого массива (практически никогда, но для безопасности)
        If Not IsArray(parts) Then
            MsgBox "Внутренняя ошибка: Split не вернул массив для строки " & i + 1, vbExclamation
            GoTo NextItem
        End If
        If UBound(parts) < 0 Then
            MsgBox "Пустая строка (без данных) в строке " & i + 1 & ". Пропущено.", vbExclamation
            GoTo NextItem
        End If

        Dim mainPart As String, extra1 As String, extra2 As String
        mainPart = Trim(parts(0))
        extra1 = ""
        extra2 = ""
        If UBound(parts) >= 1 Then extra1 = Trim(parts(1))
        If UBound(parts) >= 2 Then extra2 = Trim(parts(2))

        ' Извлекаем номер и текст из основной части
        dotPos = InStr(mainPart, ". ")
        If dotPos > 0 And IsNumeric(Left(mainPart, dotPos - 1)) Then
            numPart = Left(mainPart, dotPos + 1)    ' "1. "
            textPart = Trim(Mid(mainPart, dotPos + 2))
        Else
            numPart = ""
            textPart = mainPart
        End If

        Dim currentRow As Long
        currentRow = SavedRow + 1 + i

        ' C: номер
        With ws.Cells(currentRow, 3)
            .Value = numPart
            .Font.Bold = False
            .HorizontalAlignment = xlRight
        End With
        ' D: текст
        With ws.Cells(currentRow, 4)
            .Value = textPart
            .Font.Bold = False
        End With
        ' E: доп1
        With ws.Cells(currentRow, 5)
            .Value = extra1
            .Font.Bold = False
        End With
        ' F: доп2
        With ws.Cells(currentRow, 6)
            .Value = extra2
            .Font.Bold = False
        End With

NextItem:
    Next i

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

    ' 9. Удаление строк до следующей объединённой ячейки в C/D (как раньше)
    Dim lastInsertedRow As Long
    lastInsertedRow = SavedRow + totalLines - 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, 3), ws.Cells(SavedRow + SavedNumLines - 1, 6))
        rngRestore.Value = SavedOldData
    End If

    SavedNumLines = 0
    SavedOldData = Empty

    Application.ScreenUpdating = True
End Sub