---

Sub ВставитьСписокИДопДанные()
    Dim undoRec As UndoRecord
    Set undoRec = Application.UndoRecord
    undoRec.StartCustomRecord "Вставить список и доп. данные"

    Dim startPos As Long
    startPos = Selection.Start

    ' 1. Вставка текста из буфера
    On Error Resume Next
    Selection.PasteSpecial Link:=False, DataType:=wdPasteText, _
                           Placement:=wdInLine, DisplayAsIcon:=False
    If Err.Number <> 0 Then
        MsgBox "Не удалось вставить текст. Проверьте, скопированы ли данные.", vbExclamation
        undoRec.EndCustomRecord
        Exit Sub
    End If
    On Error GoTo 0

    ' 2. Выделяем весь вставленный текст
    Selection.SetRange Start:=startPos, End:=Selection.End

    ' 3. Сбор данных: colMain (основной текст) и colB (доп. данные)
    Dim colMain As New Collection
    Dim colB As New Collection
    Dim para As Paragraph
    For Each para In Selection.Range.Paragraphs
        If Len(para.Range.Text) > 1 Then
            Dim fullText As String
            fullText = para.Range.Text
            If Right(fullText, 1) = vbCr Then fullText = Left(fullText, Len(fullText) - 1)
            Dim parts As Variant
            parts = Split(fullText, vbTab)
            ' Игнорируем строки, где основной текст пуст
            If Len(Trim(parts(0))) > 0 Then
                colMain.Add Trim(parts(0))
                If UBound(parts) >= 1 Then
                    colB.Add Trim(parts(1))
                Else
                    colB.Add ""
                End If
            End If
        End If
    Next para

    If colMain.Count = 0 Then
        MsgBox "Основной текст не найден. Проверьте порядок столбцов (сначала D, потом B).", vbInformation
        Selection.Delete
        undoRec.EndCustomRecord
        Exit Sub
    End If

    ' 4. Удаляем вставленный текст и вставляем нумерованный список
    Selection.Delete
    Dim i As Long
    Dim numberedText As String
    numberedText = ""
    For i = 1 To colMain.Count
        numberedText = numberedText & i & ". " & colMain(i) & vbCrLf
    Next i
    If Len(numberedText) > 0 Then numberedText = Left(numberedText, Len(numberedText) - 1)
    Selection.TypeText Text:=numberedText

    ' 5. Выделяем новый список и применяем форматирование
    Selection.SetRange Start:=startPos, End:=Selection.End
    Selection.ClearFormatting
    Selection.ParagraphFormat.Reset
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
    End With
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 11
    End With
    Selection.Range.Case = wdTitleWord

    ' 6. Добавляем пустые строки сверху и снизу списка
    ' Сверху: вставляем абзац перед первым абзацем выделения
    Dim rngFirstPara As Range
    Set rngFirstPara = Selection.Paragraphs(1).Range
    rngFirstPara.InsertParagraphBefore
    ' Снизу: переходим в конец выделения и вставляем абзац
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.TypeParagraph
    ' Очищаем форматирование добавленных пустых абзацев
    Selection.ClearFormatting
    Selection.ParagraphFormat.Reset
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
    End With

    ' 7. Обработка дополнительных данных (столбец B)
    Dim firstB As String, lastB As String
    firstB = ""
    lastB = ""
    For i = 1 To colB.Count
        If Len(colB(i)) > 0 Then
            firstB = colB(i)
            Exit For
        End If
    Next i
    For i = colB.Count To 1 Step -1
        If Len(colB(i)) > 0 Then
            lastB = colB(i)
            Exit For
        End If
    Next i

    Dim digits1 As String, digits2 As String
    digits1 = ExtractLast8Digits(firstB)
    digits2 = ExtractLast8Digits(lastB)
    Dim resultB As String
    resultB = digits1 & "-" & digits2

    ' 8. Вставка дополнительных данных в соседнюю ячейку (если таблица) или на новой строке
    If Selection.Information(wdWithInTable) Then
        On Error Resume Next
        Selection.MoveRight Unit:=wdCell
        If Err.Number <> 0 Then
            ' Если не удалось перейти вправо, вставляем в ту же ячейку на новой строке
            Selection.TypeParagraph
        End If
        On Error GoTo 0
    Else
        Selection.TypeParagraph
    End If
    Selection.TypeText Text:=resultB
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 11
        .Bold = False
    End With

    undoRec.EndCustomRecord
End Sub

Private Function ExtractLast8Digits(txt As String) As String
    Dim digits As String
    digits = ""
    Dim i As Long
    For i = Len(txt) To 1 Step -1
        If Mid(txt, i, 1) Like "#" Then
            digits = Mid(txt, i, 1) & digits
            If Len(digits) >= 8 Then Exit For
        End If
    Next i
    ExtractLast8Digits = digits
End Function