---

Sub ВставитьСписокИзWordСНумерацией()
    On Error GoTo ErrorHandler

    Dim clipText As String
    Dim ws As Worksheet
    Dim rngBefore As Range
    Dim multiPart As Boolean
    Dim cell2Text As String, cell3Text As String
    Dim colLines As Collection
    Dim i As Long, numLines As Long
    Dim lineText As String, numPart As String, textPart As String
    Dim dotPos As Long

    ' 1. Получаем текст из буфера
    clipText = GetClipboardText()
    If Len(clipText) = 0 Then
        MsgBox "Буфер обмена пуст или содержит не текст.", vbInformation
        Exit Sub
    End If

    ' 2. Определяем тип буфера
    multiPart = (InStr(clipText, vbTab) > 0)
    cell2Text = ""
    cell3Text = ""

    If multiPart Then
        Dim rows() As String, rowText As String
        rows = SplitTextToLines(clipText)
        rowText = ""
        For i = 0 To UBound(rows)
            If Len(Trim(rows(i))) > 0 Then
                rowText = rows(i)
                Exit For
            End If
        Next i

        If rowText <> "" Then
            Dim parts() As String
            parts = Split(rowText, vbTab)
            If UBound(parts) >= 1 Then
                clipText = parts(0)
                If UBound(parts) >= 2 Then cell2Text = CleanString(parts(1))
                If UBound(parts) >= 3 Then cell3Text = CleanString(parts(2))
            End If
        End If
    Else
        Dim allNonEmpty() As String
        allNonEmpty = GetNonEmptyLines(clipText)
        If UBound(allNonEmpty) >= 2 Then
            clipText = allNonEmpty(0)
            cell2Text = allNonEmpty(1)
            If UBound(allNonEmpty) >= 3 Then cell3Text = allNonEmpty(2)
            multiPart = True
        Else
            multiPart = False
        End If
    End If

    ' 3. Извлекаем непустые строки из первой части
    Dim allLines() As String
    allLines = SplitTextToLines(clipText)
    Set colLines = New Collection
    For i = 0 To UBound(allLines)
        lineText = CleanString(allLines(i))
        If Len(Trim(lineText)) > 0 Then
            colLines.Add lineText
        End If
    Next i

    If colLines.Count = 0 Then
        MsgBox "Не найдено ни одной строки текста.", vbInformation
        Exit Sub
    End If
    numLines = colLines.Count

    ' 4. Сохраняем состояние ячеек (C и D)
    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 + 1))
    If Not rngBefore Is Nothing Then
        SavedOldData = rngBefore.Value
    Else
        SavedOldData = Empty
    End If

    ' 5. Вставляем строки и заполняем столбцы C и D
    Application.ScreenUpdating = False
    ws.Rows(SavedRow & ":" & SavedRow + numLines - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    For i = 1 To numLines
        ' Безопасное извлечение и очистка
        lineText = ""
        On Error Resume Next
        lineText = CStr(colLines(i))   ' принудительно превращаем в строку
        On Error GoTo ErrorHandler

        ' Пропускаем пустые строки (двойной контроль)
        If Len(Trim(lineText)) = 0 Then GoTo ContinueLoop

        ' Ищем номер
        dotPos = InStr(lineText, ". ")
        If dotPos > 0 Then
            Dim leftPart As String
            leftPart = Left(lineText, dotPos - 1)
            If IsNumeric(leftPart) And Len(leftPart) > 0 Then
                numPart = leftPart & ". "
                textPart = LTrim(Mid(lineText, dotPos + 2))
            Else
                numPart = ""
                textPart = lineText
            End If
        Else
            numPart = ""
            textPart = lineText
        End If

        ' Запись в ячейки
        With ws.Cells(SavedRow + i - 1, SavedCol)
            .Value = numPart
            .Font.Bold = False
            .HorizontalAlignment = xlRight
        End With
        With ws.Cells(SavedRow + i - 1, SavedCol + 1)
            .Value = textPart
            .Font.Bold = False
        End With

ContinueLoop:
    Next i

    ' 6. Дополнительные ячейки (E и F) один раз
    If multiPart Then
        ws.Cells(SavedRow, 5).Value = cell2Text
        ws.Cells(SavedRow, 5).Font.Bold = False
        ws.Cells(SavedRow, 6).Value = cell3Text
        ws.Cells(SavedRow, 6).Font.Bold = False
    End If

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

    ' 8. Удаление строк до объединённой ячейки в C/D
    Dim lastInsertedRow As Long, nextMergedRow As Long, r As Long
    lastInsertedRow = SavedRow + numLines - 1
    nextMergedRow = 0

    For r = lastInsertedRow + 1 To lastInsertedRow + 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 = lastInsertedRow + 1
        lastRowToDelete = nextMergedRow - 1
        If lastRowToDelete >= firstRowToDelete Then
            ws.Rows(firstRowToDelete & ":" & lastRowToDelete).Delete Shift:=xlUp
        End If
    End If

    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    MsgBox "Ошибка " & Err.Number & " в строке " & Erl & ": " & Err.Description, vbCritical, "Ошибка в макросе"
End Sub