---

' ===== В САМОМ ВЕРХУ МОДУЛЯ (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
    Dim numPart As String, textPart As String, extra1 As String, extra2 As String
    Dim dotPos As Long, numLines 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. Разбиваем на строки, отбрасываем полностью пустые
    Dim rawLines As Variant
    rawLines = Split(clipText, vbCrLf)
    If UBound(rawLines) < 0 Then rawLines = Split(clipText, vbLf)

    Dim col As New Collection
    Dim rawLine As Variant
    For Each rawLine In rawLines
        If Len(Trim(CStr(rawLine))) > 0 Then
            col.Add CStr(rawLine)
        End If
    Next rawLine

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

    ReDim linesArr(0 To col.Count - 1)
    For i = 0 To col.Count - 1
        linesArr(i) = col(i + 1)
    Next i
    numLines = col.Count

    ' 3. Сохраняем состояние ячеек, которые будут затёрты (начиная с активной)
    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 + 3))
    If Not rngBefore Is Nothing Then
        SavedOldData = rngBefore.Value
    Else
        SavedOldData = Empty
    End If

    ' 4. Вставляем строки ПОСЛЕ активной, заполняем начиная с активной
    Application.ScreenUpdating = False
    ' Вставка numLines строк после активной ячейки (сдвигает всё ниже вниз)
    ws.Rows(SavedRow + 1 & ":" & SavedRow + numLines).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    For i = 0 To numLines - 1
        lineText = linesArr(i)
        If Len(lineText) = 0 Then GoTo NextLine

        Dim parts As Variant
        parts = Split(lineText, vbTab)

        Dim v0 As Variant, v1 As Variant, v2 As Variant
        v0 = parts(0)
        If UBound(parts) >= 1 Then v1 = parts(1) Else v1 = Empty
        If UBound(parts) >= 2 Then v2 = parts(2) Else v2 = Empty

        Dim field1 As String, field2 As String, field3 As String
        field1 = SafeString(v0)
        field2 = SafeString(v1)
        field3 = SafeString(v2)

        numPart = ""
        textPart = ""
        If Len(field1) > 0 Then
            On Error Resume Next
            dotPos = InStr(field1, ". ")
            If dotPos > 0 And IsNumeric(Left(field1, dotPos - 1)) Then
                numPart = Left(field1, dotPos + 1)
                textPart = Trim(Mid(field1, dotPos + 2))
            Else
                textPart = field1
            End If
            If Err.Number <> 0 Then
                numPart = ""
                textPart = field1
                Err.Clear
            End If
            On Error GoTo 0
        End If

        With ws.Cells(SavedRow + i, SavedCol)        ' C
            .Value = numPart
            .Font.Bold = False
            .HorizontalAlignment = xlRight
        End With
        With ws.Cells(SavedRow + i, SavedCol + 1)    ' D
            .Value = textPart
            .Font.Bold = False
        End With
        With ws.Cells(SavedRow + i, SavedCol + 2)    ' E
            .Value = field2
            .Font.Bold = False
        End With
        With ws.Cells(SavedRow + i, SavedCol + 3)    ' F
            .Value = field3
            .Font.Bold = False
        End With
NextLine:
    Next i

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

    ' 6. Принудительная очистка ячеек от невидимых символов, затем удаление пустых строк (кроме первой)
    Dim lastRow As Long
    lastRow = SavedRow + numLines - 1

    For i = SavedRow To lastRow
        Dim cell As Range
        For Each cell In ws.Range(ws.Cells(i, SavedCol), ws.Cells(i, SavedCol + 3))
            If Not IsEmpty(cell.Value) Then
                If Len(DeepClean(CStr(cell.Value))) = 0 Then
                    cell.ClearContents
                End If
            End If
        Next cell
    Next i

    For i = lastRow To SavedRow + 1 Step -1
        If WorksheetFunction.CountA(ws.Range(ws.Cells(i, SavedCol), ws.Cells(i, SavedCol + 3))) = 0 Then
            ws.Rows(i).Delete Shift:=xlUp
            numLines = numLines - 1
        End If
    Next i
    lastRow = SavedRow + numLines - 1

    ' 7. Объединяем C и D в первой строке
    If numLines > 0 Then
        Dim rngFirstCD As Range
        Set rngFirstCD = ws.Range(ws.Cells(SavedRow, SavedCol), ws.Cells(SavedRow, SavedCol + 1))
        If rngFirstCD.MergeCells Then rngFirstCD.UnMerge
        Dim firstText As String
        firstText = SuperClean(CStr(ws.Cells(SavedRow, SavedCol + 1).Value))
        If Len(firstText) = 0 Then
            firstText = SuperClean(CStr(ws.Cells(SavedRow, SavedCol).Value))
        End If
        rngFirstCD.Merge
        rngFirstCD.Value = firstText
        rngFirstCD.Font.Bold = False
    End If

    ' 8. Умное объединение E и F
    If numLines > 0 Then
        Dim rngE As Range, rngF As Range
        Set rngE = ws.Range(ws.Cells(SavedRow, SavedCol + 2), ws.Cells(lastRow, SavedCol + 2))
        Set rngF = ws.Range(ws.Cells(SavedRow, SavedCol + 3), ws.Cells(lastRow, SavedCol + 3))

        Dim dictE As Object, dictF As Object
        Set dictE = CreateObject("Scripting.Dictionary")
        Set dictF = CreateObject("Scripting.Dictionary")

        For i = 0 To numLines - 1
            Dim vE As Variant, vF As Variant
            vE = ws.Cells(SavedRow + i, SavedCol + 2).Value
            vF = ws.Cells(SavedRow + i, SavedCol + 3).Value
            If Not IsEmpty(vE) Then
                Dim normE As String
                normE = SuperClean(CStr(vE))
                If Len(normE) > 0 Then dictE(normE) = True
            End If
            If Not IsEmpty(vF) Then
                Dim normF As String
                normF = SuperClean(CStr(vF))
                If Len(normF) > 0 Then dictF(normF) = True
            End If
        Next i

        If dictE.Count = 1 Then
            If rngE.MergeCells Then rngE.UnMerge
            Dim uniqueE As String
            uniqueE = dictE.Keys()(0)
            rngE.ClearContents
            rngE(1).Value = uniqueE
            rngE(1).Font.Bold = False
            rngE.Merge
        End If

        If dictF.Count = 1 Then
            If rngF.MergeCells Then rngF.UnMerge
            Dim uniqueF As String
            uniqueF = dictF.Keys()(0)
            rngF.ClearContents
            rngF(1).Value = uniqueF
            rngF(1).Font.Bold = False
            rngF.Merge
        End If
    End If

    ' 9. Финальная проверка: удаляем последнюю строку, если она всё ещё пустая
    If numLines > 1 Then
        Dim lastCheckRow As Long
        lastCheckRow = SavedRow + numLines - 1
        Dim finalEmpty As Boolean
        finalEmpty = True
        Dim c As Long
        For c = SavedCol To SavedCol + 3
            Dim val As Variant
            val = ws.Cells(lastCheckRow, c).Value
            If Not IsEmpty(val) Then
                If Len(DeepClean(CStr(val))) > 0 Then
                    finalEmpty = False
                    Exit For
                End If
            End If
        Next c
        If finalEmpty Then
            ws.Rows(lastCheckRow).Delete Shift:=xlUp
            numLines = numLines - 1
            lastRow = lastRow - 1
        End If
    End If

    ' 10. Удаление строк от следующих за вставленными до следующей объединённой ячейки в C или D
    Dim nextMergedRow As Long
    nextMergedRow = 0
    Dim maxRow As Long
    maxRow = ws.Rows.Count
    Dim r As Long
    For r = lastRow + 1 To WorksheetFunction.Min(lastRow + 1000, maxRow)
        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 = lastRow + 1
        lastRowToDelete = nextMergedRow - 1
        If lastRowToDelete >= firstRowToDelete Then
            ws.Rows(firstRowToDelete & ":" & lastRowToDelete).Delete Shift:=xlUp
        End If
    End If

    Application.ScreenUpdating = True
End Sub

' Глубокая очистка от всех невидимых символов
Private Function DeepClean(txt As String) As String
    If Len(txt) = 0 Then Exit Function
    Dim result As String
    result = txt
    result = Replace(result, ChrW(160), "")   ' неразрывный пробел
    result = Replace(result, ChrW(8203), "")  ' нулевой пробел
    result = Replace(result, ChrW(8204), "")  ' невидимый разделитель
    result = Replace(result, ChrW(8205), "")  ' невидимый соединитель
    result = Replace(result, ChrW(65279), "") ' BOM
    result = Replace(result, ChrW(173), "")   ' мягкий перенос
    result = Replace(result, ChrW(8206), "")  ' LTR
    result = Replace(result, ChrW(8207), "")  ' RTL
    result = Replace(result, vbTab, "")
    result = Replace(result, vbCrLf, "")
    result = Replace(result, vbLf, "")
    result = Replace(result, vbCr, "")
    Dim i As Long
    Dim cleanStr As String
    cleanStr = ""
    For i = 1 To Len(result)
        Dim charCode As Long
        charCode = AscW(Mid(result, i, 1))
        If (charCode >= 32 And charCode <= 126) Or charCode > 159 Then
            cleanStr = cleanStr & Mid(result, i, 1)
        End If
    Next i
    result = cleanStr
    While InStr(result, "  ") > 0
        result = Replace(result, "  ", " ")
    Wend
    DeepClean = Trim(result)
End Function

Private Function SuperClean(txt As String) As String
    If Len(txt) = 0 Then Exit Function
    Dim result As String
    result = txt
    result = Replace(result, Chr(160), " ")
    result = Replace(result, vbTab, " ")
    result = Replace(result, vbCrLf, " ")
    result = Replace(result, vbLf, " ")
    result = Replace(result, vbCr, " ")
    While InStr(result, "  ") > 0
        result = Replace(result, "  ", " ")
    Wend
    SuperClean = Trim(result)
End Function

Private Function SafeString(v As Variant) As String
    If IsNull(v) Or IsError(v) Then
        SafeString = ""
    Else
        SafeString = Trim(CStr(v))
    End If
End Function

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 + 3))
        rngRestore.Value = SavedOldData
    End If

    SavedNumLines = 0
    SavedOldData = Empty

    Application.ScreenUpdating = True
End Sub