---

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

Sub ВставитьСписокИзWordСНумерацией()
    On Error GoTo ErrorHandler

    Dim clipText As String
    Dim ws As Worksheet
    Dim rngBefore As Range
    Dim multiPart As Boolean
    Dim cell2Text As String, cell3Text As String
    Dim colLines As Collection
    Dim i As Long, numLines As Long
    Dim lineText As String, numPart As String, textPart As String
    Dim dotPos As Long

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

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

    If multiPart Then
        ' Ищем первую непустую строку с табуляциями
        Dim rows() As String, rowText As String
        rows = SplitTextToLines(clipText) ' наша безопасная функция
        rowText = ""
        For i = 0 To UBound(rows)
            If Len(Trim(rows(i))) > 0 Then
                rowText = rows(i)
                Exit For
            End If
        Next i

        If rowText <> "" Then
            Dim parts() As String
            parts = Split(rowText, vbTab)
            If UBound(parts) >= 1 Then
                ' Первая часть до табуляции — основной текст
                clipText = parts(0)
                If UBound(parts) >= 2 Then
                    cell2Text = parts(1)
                End If
                If UBound(parts) >= 3 Then
                    cell3Text = parts(2)
                End If
                ' Очищаем от невидимых символов
                cell2Text = CleanString(cell2Text)
                cell3Text = CleanString(cell3Text)
            End If
        End If
    End If

    ' 3. Извлекаем непустые строки из основного текста
    Dim allLines() As String
    allLines = SplitTextToLines(clipText)
    Set colLines = New Collection
    For i = 0 To UBound(allLines)
        lineText = CleanString(allLines(i))
        If Len(Trim(lineText)) > 0 Then
            colLines.Add lineText
        End If
    Next i

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

    ' 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 = 1 To numLines
        lineText = colLines(i)
        ' Поиск номера с точкой и пробелом
        dotPos = InStr(lineText, ". ")
        If dotPos > 0 Then
            Dim leftPart As String
            leftPart = Left(lineText, dotPos - 1)
            ' Проверяем, что левая часть — число
            If IsNumeric(leftPart) And Len(leftPart) > 0 Then
                numPart = leftPart & ". "
                textPart = Mid(lineText, dotPos + 2)
            Else
                numPart = ""
                textPart = lineText
            End If
        Else
            numPart = ""
            textPart = lineText
        End If

        ' Убираем возможные пробелы в начале текста
        textPart = LTrim(textPart)

        ' Запись в столбцы
        With ws.Cells(SavedRow + i - 1, SavedCol)
            .Value = numPart
            .Font.Bold = False
            .HorizontalAlignment = xlRight
        End With

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

        If multiPart Then
            ws.Cells(SavedRow + i - 1, 5).Value = cell2Text  ' E
            ws.Cells(SavedRow + i - 1, 5).Font.Bold = False
            ws.Cells(SavedRow + i - 1, 6).Value = cell3Text  ' F
            ws.Cells(SavedRow + i - 1, 6).Font.Bold = False
        End If
    Next i

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

    ' 7. Удаление строк до объединённой ячейки в C/D
    Dim lastInsertedRow As Long, nextMergedRow As Long, r As Long
    lastInsertedRow = SavedRow + numLines - 1
    nextMergedRow = 0

    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
    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    MsgBox "Ошибка " & Err.Number & ": " & Err.Description & vbCrLf & _
           "Процедура: ВставитьСписокИзWordСНумерацией" & vbCrLf & _
           "Содержимое буфера (первые 100 символов): " & vbCrLf & Left(clipText, 100), vbCritical, "Ошибка в макросе"
End Sub

' ============================================================
' Безопасное получение текста из буфера обмена
' ============================================================
Private Function GetClipboardText() As String
    On Error Resume Next
    Dim dataObj As Object
    Set dataObj = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    If Err.Number <> 0 Then
        Err.Clear
        Set dataObj = CreateObject("MSForms.DataObject")
    End If
    On Error GoTo 0

    If dataObj Is Nothing Then
        GetClipboardText = ""
        Exit Function
    End If

    dataObj.GetFromClipboard
    Dim txt As String
    txt = ""
    On Error Resume Next
    txt = dataObj.GetText
    If Err.Number <> 0 Then
        txt = ""
    End If
    On Error GoTo 0
    ' Защита от Null/Empty
    If IsNull(txt) Then txt = ""
    GetClipboardText = txt
End Function

' ============================================================
' Разбиение текста на строки с любыми разделителями (CR, LF, CR+LF)
' ============================================================
Private Function SplitTextToLines(ByVal text As String) As String()
    Dim result() As String
    ReDim result(0 To 0)
    If Len(text) = 0 Then
        SplitTextToLines = result
        Exit Function
    End If

    Dim i As Long, j As Long
    Dim ch As String
    Dim curLine As String
    Dim col As New Collection
    curLine = ""

    For i = 1 To Len(text)
        ch = Mid(text, i, 1)
        If ch = vbCr Or ch = vbLf Then
            ' Сохраняем текущую строку, если не пустая
            If Len(curLine) > 0 Then
                col.Add curLine
                curLine = ""
            End If
            ' Если это CR, следующий символ может быть LF — пропускаем его
            If ch = vbCr And i < Len(text) Then
                If Mid(text, i + 1, 1) = vbLf Then
                    i = i + 1 ' пропускаем LF
                End If
            End If
        Else
            curLine = curLine & ch
        End If
    Next i
    ' Последняя строка
    If Len(curLine) > 0 Then
        col.Add curLine
    End If

    If col.Count = 0 Then
        ReDim result(0 To 0)
        result(0) = ""
    Else
        ReDim result(0 To col.Count - 1)
        For i = 1 To col.Count
            result(i - 1) = col(i)
        Next i
    End If
    SplitTextToLines = result
End Function

' ============================================================
' Очистка строки от непечатных символов
' ============================================================
Private Function CleanString(ByVal txt As String) As String
    If Len(txt) = 0 Then
        CleanString = ""
        Exit Function
    End If
    txt = Replace(txt, Chr(160), " ")
    Dim i As Long
    For i = 1 To 31
        If i <> 9 And i <> 10 And i <> 13 Then
            txt = Replace(txt, Chr(i), "")
        End If
    Next i
    CleanString = txt
End Function

' ============================================================
' Отмена последней вставки
' ============================================================
Sub ОтменитьПоследнююВставкуСписка()
    On Error GoTo CancelError
    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
    Exit Sub

CancelError:
    Application.ScreenUpdating = True
    MsgBox "Ошибка при отмене: " & Err.Description, vbExclamation
End Sub