---

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, numPart As String, textPart As String
    Dim dotPos As Long, numLines As Long, ws As Worksheet, firstField As String
    Dim lastE As String, lastF As String

    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

    Dim rawLines As Variant, col As New Collection, rawLine As Variant
    rawLines = Split(clipText, vbCrLf)
    If UBound(rawLines) < 0 Then rawLines = Split(clipText, vbLf)
    For Each rawLine In rawLines
        If Len(Trim(CStr(rawLine))) > 0 Then col.Add CStr(rawLine)
    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

    Set ws = ActiveSheet
    SavedRow = ActiveCell.Row
    SavedCol = ActiveCell.Column
    SavedNumLines = numLines

    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, v0 As Variant, v1 As Variant, v2 As Variant
        parts = Split(lineText, vbTab)
        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
            On Error GoTo 0
        End If

        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
NextLine:
    Next i

    ws.Rows(SavedRow & ":" & SavedRow + numLines - 1).EntireRow.AutoFit

    Dim lastRow As Long, j As Long
    lastRow = SavedRow + numLines - 1
    For j = lastRow To SavedRow + 1 Step -1
        If WorksheetFunction.CountA(ws.Rows(j)) = 0 Then
            ws.Rows(j).Delete Shift:=xlUp
            numLines = numLines - 1
        End If
    Next j
    lastRow = SavedRow + numLines - 1

    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

    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
        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

    If numLines > 0 Then
        Dim maxCol As Long, colIdx 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

        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, rSearch As Long, cellVal As Variant
            lastVal = ""
            For rSearch = lastRow To SavedRow Step -1
                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
            Next rSearch
            rngCol.ClearContents: rngCol.Merge
            If Len(lastVal) > 0 Then rngCol(1).Value = lastVal: rngCol(1).Font.Bold = False
ContinueCol:
        Next colIdx
    End If

    If numLines > 0 Then
        Dim rngH As Range, hValue As Variant
        Set rngH = ws.Range(ws.Cells(SavedRow, 8), ws.Cells(lastRow, 8))
        If Not rngH.MergeCells And rngH.Count > 1 Then rngH.Merge
        hValue = Trim(CStr(ws.Cells(SavedRow, 8).Value))
        If hValue = "-" Then rngH.HorizontalAlignment = xlCenter Else rngH.HorizontalAlignment = xlLeft
        rngH.VerticalAlignment = xlTop
    End If

    If numLines > 1 And 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

    Dim r As Long, 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

    If numLines > 0 Then
        Dim tmpSheet As Worksheet, tmpCell As Range
        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.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
    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
    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 Function