---

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. Очистка форматирования
    Selection.ClearFormatting
    Selection.ParagraphFormat.Reset
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
        .FirstLineIndent = 0
        .LeftIndent = 0
        .RightIndent = 0
    End With
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 11
    End With
    Selection.Range.Case = wdTitleWord

    ' 4. Сбор строк из буфера
    Dim colMain As New Collection  ' основной текст (D)
    Dim colB As New Collection     ' доп. данные (B)
    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)
            colMain.Add parts(0)
            If UBound(parts) >= 1 Then
                colB.Add Trim(parts(1))
            Else
                colB.Add ""
            End If
        End If
    Next para

    If colMain.Count = 0 Then
        MsgBox "Нет данных для вставки.", vbInformation
        Selection.Delete
        undoRec.EndCustomRecord
        Exit Sub
    End If

    ' 5. Удаляем вставленный текст и формируем нумерованный список
    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

    ' 6. Повторно выделяем список и применяем форматирование
    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

    ' 7. Добавляем пустые строки сверху и снизу
    Selection.HomeKey Unit:=wdLine
    Selection.InsertParagraphBefore
    Selection.EndKey Unit:=wdLine
    Selection.TypeParagraph
    ' Очищаем форматирование пустых строк
    Selection.ClearFormatting
    Selection.ParagraphFormat.Reset
    With Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LineSpacingRule = wdLineSpaceSingle
    End With

    ' 8. Обработка дополнительных данных (столбец 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

    ' 9. Вставка результата в соседнюю ячейку справа (или в текст)
    If Selection.Information(wdWithInTable) Then
        Selection.MoveRight Unit:=wdCell
    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