---

' ===== В САМОМ ВЕРХУ МОДУЛЯ (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
    Dim firstField As String
    Dim lastE As String, lastF 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. Разбиваем на строки, отбрасываем полностью пустые
    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. Сохраняем состояние ячеек (столбцы C-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 + 1 & ":" & SavedRow + numLines).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    firstField = ""
    lastE = ""
    lastF = ""
    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(field2) > 0 Then lastE = field2
        If Len(field3) > 0 Then lastF = field3
        If i = 0 Then firstField = field1

        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 = lastRow To SavedRow + 1 Step -1
        If WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
            ws.Rows(i).Delete Shift:=xlUp
            numLines = numLines - 1
        End If
    Next i
    lastRow = SavedRow + numLines - 1

    ' 7. Объединяем C и D в первой строке, выравниваем влево и первые 4 символа жирным
    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
        rngFirstCD.Merge
        rngFirstCD.Value = firstField
        rngFirstCD.Font.Bold = False
        rngFirstCD.HorizontalAlignment = xlLeft
        If Len(firstField) >= 4 Then
            rngFirstCD.Characters(1, 4).Font.Bold = True
        ElseIf Len(firstField) > 0 Then
            rngFirstCD.Characters(1, Len(firstField)).Font.Bold = True
        End If
    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))

        If Not HasAnyFormula(rngE) Then
            If rngE.MergeCells Then rngE.UnMerge
            rngE.ClearContents
            rngE.Merge
            If Len(lastE) > 0 Then
                rngE(1).Value = lastE
                rngE(1).Font.Bold = False
            End If
        End If

        If Not HasAnyFormula(rngF) Then
            If rngF.MergeCells Then rngF.UnMerge
            rngF.ClearContents
            rngF.Merge
            If Len(lastF) > 0 Then
                rngF(1).Value = lastF
                rngF(1).Font.Bold = False
            End If
        End If
    End If

    ' 9. Объединяем ВСЕ ОСТАЛЬНЫЕ СТОЛБЦЫ (кроме C и D), если они не пустые
    If numLines > 0 Then
        Dim maxCol As Long
        On Error Resume Next
        maxCol = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        If Err.Number <> 0 Then maxCol = 8
        On Error GoTo 0
        If maxCol < 8 Then maxCol = 8

        Dim colIdx As Long
        For colIdx = 1 To maxCol
            If colIdx = 3 Or colIdx = 4 Then GoTo ContinueCol

            Dim rngCol As Range
            Set rngCol = ws.Range(ws.Cells(SavedRow, colIdx), ws.Cells(lastRow, colIdx))

            ' Пропускаем полностью пустые столбцы без формул (оптимизация)
            If Application.CountA(rngCol) = 0 And Not HasAnyFormula(rngCol) Then GoTo ContinueCol

            ' Если есть формулы — только объединяем и выравниваем, не трогая содержимое
            If HasAnyFormula(rngCol) Then
                If rngCol.MergeCells Then rngCol.UnMerge
                rngCol.Merge
                rngCol.HorizontalAlignment = xlLeft
                rngCol.VerticalAlignment = xlTop
                GoTo ContinueCol
            End If

            ' Для обычных столбцов: снимаем объединение, ищем последнее непустое, объединяем
            If rngCol.MergeCells Then rngCol.UnMerge

            Dim lastVal As String
            lastVal = ""
            Dim rSearch As Long
            For rSearch = lastRow To SavedRow Step -1
                Dim cellVal As Variant
                cellVal = ws.Cells(rSearch, colIdx).Value
                If Not IsEmpty(cellVal) Then
                    Dim cleanVal As String
                    cleanVal = Trim(CStr(cellVal))   ' используем обычный Trim, а не DeepClean
                    If Len(cleanVal) > 0 Then
                        lastVal = cleanVal
                        Exit For
                    End If
                End If
            Next rSearch

            rngCol.ClearContents
            rngCol.Merge
            If Len(lastVal) > 0 Then
                rngCol(1).Value = lastVal
                rngCol(1).Font.Bold = False
            End If
ContinueCol:
        Next colIdx
    End If

    ' 10. Финальное удаление последней пустой строки
    If numLines > 1 Then
        If WorksheetFunction.CountA(ws.Rows(SavedRow + numLines - 1)) = 0 Then
            ws.Rows(SavedRow + numLines - 1).Delete Shift:=xlUp
            numLines = numLines - 1
            lastRow = lastRow - 1
        End If
    End If

    ' 11. Удаление старых строк до следующей объединённой ячейки в C/D,
    '     но НЕ удаляем строки, содержащие хотя бы одну формулу
    Dim r As Long
    Dim maxRow As Long
    maxRow = ws.Rows.Count
    r = lastRow + 1
    Do While r <= maxRow
        If RowHasAnyFormula(ws.Rows(r)) Then Exit Do
        If ws.Cells(r, 3).MergeCells Or ws.Cells(r, 4).MergeCells Then Exit Do
        ws.Rows(r).Delete Shift:=xlUp
        maxRow = ws.Rows.Count
    Loop

    Application.ScreenUpdating = True
End Sub

' Функция: есть ли хотя бы одна формула в диапазоне?
Private Function HasAnyFormula(rng As Range) As Boolean
    Dim cell As Range
    For Each cell In rng.Cells
        If cell.HasFormula Then
            HasAnyFormula = True
            Exit Function
        End If
    Next cell
    HasAnyFormula = False
End Function

' Функция: есть ли хотя бы одна формула в строке?
Private Function RowHasAnyFormula(rng As Range) As Boolean
    Dim cell As Range
    For Each cell In rng.Columns
        If cell.HasFormula Then
            RowHasAnyFormula = True
            Exit Function
        End If
    Next cell
    RowHasAnyFormula = False
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