---

' ===== В САМОМ ВЕРХУ МОДУЛЯ (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
    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. Сохраняем состояние ячеек (столбцы 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. Единая запись отмены
    Dim undoRec As Object
    On Error Resume Next
    Set undoRec = Application.UndoRecord
    On Error GoTo 0
    If Not undoRec Is Nothing Then
        undoRec.StartCustomRecord "Вставить список из Word"
    End If

    ' 5. Заполняем ячейки (с защитой от ошибок)
    Application.ScreenUpdating = False

    For i = 0 To numLines - 1
        lineText = linesArr(i)
        numPart = ""
        textPart = ""
        Dim field2 As String, field3 As String
        field2 = ""
        field3 = ""

        On Error GoTo SkipLine

        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
        field1 = SafeString(v0)
        field2 = SafeString(v1)
        field3 = SafeString(v2)

        If Len(field1) > 0 Then
            dotPos = InStr(field1, ". ")
            If dotPos > 0 And dotPos > 1 Then
                Dim leftPart As String
                leftPart = Left(field1, dotPos - 1)
                If IsNumeric(leftPart) Then
                    numPart = Left(field1, dotPos + 1)
                    textPart = Trim(Mid(field1, dotPos + 2))
                Else
                    textPart = field1
                End If
            Else
                textPart = field1
            End If
        End If
        On Error GoTo 0

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

SkipLine:
        On Error GoTo 0
        With ws.Range(ws.Cells(SavedRow + i, SavedCol), ws.Cells(SavedRow + i, SavedCol + 3))
            .Value = "": .Font.Bold = False
        End With
NextLine:
    Next i

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

    ' 7. Удаляем последнюю строку, только если она реально пустая и без номера
    Dim lastRow As Long
    lastRow = SavedRow + numLines - 1

    If numLines > 1 Then
        If Not ws.Cells(lastRow, SavedCol).MergeCells Then
            If Not HasNumberInC(ws, lastRow, SavedCol) And IsRowEmpty(ws, lastRow, SavedCol, SavedCol + 3) Then
                ws.Rows(lastRow).Delete Shift:=xlUp
                numLines = numLines - 1
                lastRow = lastRow - 1
            End If
        End If
    End If

    ' 8. Горизонтальное объединение 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 = Trim(CStr(ws.Cells(SavedRow, SavedCol + 1).Value))
        If Len(firstText) = 0 Then firstText = Trim(CStr(ws.Cells(SavedRow, SavedCol).Value))
        rngFirstCD.Merge
        rngFirstCD.Value = firstText
        rngFirstCD.Font.Bold = False
    End If

    ' 9. Вертикальное объединение E и F (если одинаковые значения)
    If numLines > 1 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

    If Not undoRec Is Nothing Then undoRec.EndCustomRecord
    Application.ScreenUpdating = True
End Sub

Private Function IsRowEmpty(ws As Worksheet, rowNum As Long, colStart As Long, colEnd As Long) As Boolean
    Dim c As Long
    For c = colStart To colEnd
        Dim vv As Variant: vv = ws.Cells(rowNum, c).Value
        If Not IsEmpty(vv) Then
            If Len(SuperClean(CStr(vv))) > 0 Then Exit Function
        End If
    Next c
    IsRowEmpty = True
End Function

Private Function HasNumberInC(ws As Worksheet, rowNum As Long, colNum As Long) As Boolean
    Dim cellVal As Variant: cellVal = ws.Cells(rowNum, colNum).Value
    If IsEmpty(cellVal) Then Exit Function
    Dim txt As String: txt = Trim(CStr(cellVal))
    If Len(txt) = 0 Then Exit Function
    Dim pos As Long: pos = InStr(txt, ". ")
    If pos > 1 Then
        If IsNumeric(Left(txt, pos - 1)) Then HasNumberInC = True
    End If
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 Function