---

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

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

    ' 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

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

    Dim firstField As String
    Dim lastE As String, lastF As String
    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
        rngFirstCD.WrapText = True
        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))
                    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. Специальная обработка столбца H (индекс 8)
    If numLines > 0 Then
        Dim rngH As Range
        Set rngH = ws.Range(ws.Cells(SavedRow, 8), ws.Cells(lastRow, 8))
        
        If Not rngH.MergeCells Then
            If rngH.Count > 1 Then rngH.Merge
        End If
        
        Dim hValue As Variant
        hValue = Trim(CStr(ws.Cells(SavedRow, 8).Value))
        If hValue = "-" Then
            rngH.HorizontalAlignment = xlCenter
        Else
            rngH.HorizontalAlignment = xlLeft
        End If
        rngH.VerticalAlignment = xlTop
    End If

    ' 11. Финальное удаление последней пустой строки
    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

    ' 12. Удаление старых строк до следующей объединённой ячейки в 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

    ' 13. УСТАНОВКА ВЫСОТЫ ПЕРВОЙ СТРОКИ ПО РЕАЛЬНОМУ СОДЕРЖИМОМУ C/D
    If numLines > 0 Then
        Dim tmpSheet As Worksheet
        Dim tmpCell As Range
        Application.ScreenUpdating = False
        ' Создаём временный лист
        Set tmpSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        Set tmpCell = tmpSheet.Range("A1")
        ' Переносим текст и форматирование
        tmpCell.Value = firstField
        tmpCell.Font.Name = "Times New Roman"
        tmpCell.Font.Size = 11
        tmpCell.WrapText = True
        tmpCell.HorizontalAlignment = xlLeft
        ' Ширина временной ячейки = сумма ширин столбцов C и D
        tmpCell.ColumnWidth = ws.Range("C1").ColumnWidth + ws.Range("D1").ColumnWidth
        ' Подгоняем высоту
        tmpCell.EntireRow.AutoFit
        ' Применяем высоту к первой строке
        ws.Rows(SavedRow).RowHeight = tmpCell.RowHeight
        ' Удаляем временный лист
        Application.DisplayAlerts = False
        tmpSheet.Delete
        Application.DisplayAlerts = True
    End If

    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