---

' ===== В САМОМ ВЕРХУ МОДУЛЯ (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
        ' Очищаем строку от табуляций и неразрывных пробелов, затем проверяем на пустоту
        Dim cleaned As String
        cleaned = CleanText(CStr(rawLine))
        If Len(cleaned) > 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. Сохраняем состояние ячеек (столбцы C, D, E, F)
    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
    ws.Rows(SavedRow & ":" & SavedRow + numLines - 1).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)

        If Len(field1) > 0 Then
            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
                numPart = ""
                textPart = field1
            End If
        Else
            numPart = ""
            textPart = ""
        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
    Dim allEmpty As Boolean
    allEmpty = True
    For i = SavedCol To SavedCol + 3
        Dim cellVal As Variant
        cellVal = ws.Cells(lastRow, i).Value
        If Not IsEmpty(cellVal) Then
            Dim strVal As String
            strVal = CleanText(CStr(cellVal))
            If Len(strVal) > 0 Then
                allEmpty = False
                Exit For
            End If
        End If
    Next i
    If allEmpty Then
        ws.Rows(lastRow).Delete Shift:=xlUp
        numLines = numLines - 1
        lastRow = lastRow - 1
    End If

    ' 7. Вертикальное объединение одинаковых значений в C и D (с нормализацией)
    Dim rngC As Range, rngD As Range
    Set rngC = ws.Range(ws.Cells(SavedRow, SavedCol), ws.Cells(lastRow, SavedCol))
    Set rngD = ws.Range(ws.Cells(SavedRow, SavedCol + 1), ws.Cells(lastRow, SavedCol + 1))

    Dim dictC As Object, dictD As Object
    Set dictC = CreateObject("Scripting.Dictionary")
    Set dictD = CreateObject("Scripting.Dictionary")

    For i = 0 To numLines - 1
        Dim vC As Variant, vD As Variant
        vC = ws.Cells(SavedRow + i, SavedCol).Value
        vD = ws.Cells(SavedRow + i, SavedCol + 1).Value
        ' Нормализуем для сравнения
        If Not IsEmpty(vC) Then
            Dim normC As String
            normC = CleanText(CStr(vC))
            If Len(normC) > 0 Then dictC(normC) = True
        End If
        If Not IsEmpty(vD) Then
            Dim normD As String
            normD = CleanText(CStr(vD))
            If Len(normD) > 0 Then dictD(normD) = True
        End If
    Next i

    If dictC.Count = 1 And numLines > 1 Then
        Dim uniqueC As String
        uniqueC = dictC.Keys()(0)
        rngC.ClearContents
        rngC(1).Value = uniqueC
        rngC(1).Font.Bold = False
        rngC(1).HorizontalAlignment = xlRight
        rngC.Merge
    End If

    If dictD.Count = 1 And numLines > 1 Then
        Dim uniqueD As String
        uniqueD = dictD.Keys()(0)
        rngD.ClearContents
        rngD(1).Value = uniqueD
        rngD(1).Font.Bold = False
        rngD.Merge
    End If

    ' 8. Умное объединение столбцов E и F (как раньше, с нормализацией)
    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 = CleanText(CStr(vE))
            If Len(normE) > 0 Then dictE(normE) = True
        End If
        If Not IsEmpty(vF) Then
            Dim normF As String
            normF = CleanText(CStr(vF))
            If Len(normF) > 0 Then dictF(normF) = True
        End If
    Next i

    If dictE.Count = 1 Then
        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
        Dim uniqueF As String
        uniqueF = dictF.Keys()(0)
        rngF.ClearContents
        rngF(1).Value = uniqueF
        rngF(1).Font.Bold = False
        rngF.Merge
    End If

    ' 9. (Опционально) Горизонтальное объединение C и D в первой строке
    '    Если нужно, чтобы верхняя строка C и D стала одной ячейкой — раскомментируйте 3 строки ниже
    ' If numLines > 0 Then
    '     ws.Range(ws.Cells(SavedRow, SavedCol), ws.Cells(SavedRow, SavedCol + 1)).Merge
    ' End If

    ' 10. Удаление строк до следующей объединённой ячейки в C или D
    Dim nextMergedRow As Long
    nextMergedRow = 0

    Dim r As Long
    For r = lastRow + 1 To lastRow + 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 = 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 SafeString(v As Variant) As String
    If IsNull(v) Or IsError(v) Then
        SafeString = ""
    Else
        SafeString = Trim(CStr(v))
    End If
End Function

' Функция очистки текста: удаляет табуляции, неразрывные пробелы и лишние обычные пробелы
Private Function CleanText(txt As String) As String
    Dim result As String
    result = txt
    ' Заменяем табуляции на пробел
    result = Replace(result, vbTab, " ")
    ' Заменяем неразрывный пробел (Chr 160) на обычный
    result = Replace(result, Chr(160), " ")
    ' Удаляем множественные пробелы
    While InStr(result, "  ") > 0
        result = Replace(result, "  ", " ")
    Wend
    CleanText = Trim(result)
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