---

Sub ВставитьСписокИДопДанные()
    ' Единая запись отмены
    Dim undoRec As UndoRecord
    Set undoRec = Application.UndoRecord
    undoRec.StartCustomRecord "Вставить список и доп. данные"
    
    Dim startPos As Long
    Dim i As Long
    Dim para As Paragraph
    Dim colParasMain As Collection    ' для основных строк (из D)
    Dim arrB As Variant               ' массив доп. данных (из B)
    Dim rngFirst As Range
    
    ' Запоминаем позицию курсора до вставки
    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

    ' 4. Шрифт Times New Roman 11
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 11
    End With

    ' 5. Первая буква каждого слова — заглавная
    Selection.Range.Case = wdTitleWord

    ' 6. Сбор непустых абзацев и разделение на основной и доп. данные
    Set colParasMain = New Collection
    ReDim arrB(1 To Selection.Range.Paragraphs.Count) ' максимум
    Dim countB As Long
    countB = 0
    
    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)
            End If
            
            ' Разделяем по табуляции
            Dim parts As Variant
            parts = Split(fullText, vbTab)
            
            Dim mainText As String
            Dim extraText As String
            mainText = parts(0)
            If UBound(parts) >= 1 Then
                extraText = Trim(parts(1))
            Else
                extraText = ""
            End If
            
            ' Добавляем основной текст в коллекцию
            colParasMain.Add mainText & vbCr ' добавляем маркер обратно для InsertBefore
            
            ' Сохраняем доп. данные (если не пусто)
            If Len(extraText) > 0 Then
                countB = countB + 1
                arrB(countB) = extraText
            End If
        End If
    Next para

    If colParasMain.Count = 0 Then
        MsgBox "Не найдено ни одной строки основного текста.", vbInformation
        Selection.Collapse Direction:=wdCollapseEnd
        undoRec.EndCustomRecord
        Exit Sub
    End If

    ' 7. Нумерация основных строк (поверх существующего текста)
    i = 1
    Dim paraMain As Variant
    For Each paraMain In colParasMain
        ' paraMain — это строка, вставленная в абзац. Мы будем вставлять номер перед ней
        ' Но у нас сейчас выделен весь текст, нам нужно работать с абзацами
        ' Лучше заново перебрать абзацы выделенного текста, сохранив ссылки
    Next paraMain
    
    ' Альтернативный способ: т.к. мы уже имеем коллекцию colParasMain строк,
    ' мы можем просто заменить текст в каждом непустом абзаце нумерованным.
    ' Очистим выделенный текст и вставим заново с номерами.
    Selection.Delete ' удаляем вставленный текст, будем вставлять оформленный список
    
    ' Вставляем оформленный список из colParasMain
    Dim numberedLines As String
    numberedLines = ""
    i = 1
    Dim lineText As Variant
    For Each lineText In colParasMain
        ' убираем маркер vbCr, который мы добавляли, чтобы вставить номер
        Dim cleanLine As String
        cleanLine = Left(lineText, Len(lineText) - 1)
        numberedLines = numberedLines & i & ". " & cleanLine & vbCrLf
        i = i + 1
    Next lineText
    
    ' Убираем последний лишний перенос строки
    If Len(numberedLines) > 0 Then
        numberedLines = Left(numberedLines, Len(numberedLines) - 1)
    End If
    
    Selection.TypeText Text:=numberedLines
    
    ' Теперь выделяем вставленный нумерованный список
    Selection.SetRange Start:=startPos, End:=Selection.End
    
    ' Применяем заглавные буквы ко всему тексту (уже было, но после новой вставки нужно заново)
    Selection.Range.Case = wdTitleWord
    
    ' Шрифт и абзац уже были применены, но после удаления/вставки сбросились, применим снова
    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
    
    ' 8. Добавляем пустые строки сверху и снизу
    ' Сначала сверху
    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
    
    ' 9. Обработка доп. данных из столбца B
    If countB > 0 Then
        Dim firstB As String, lastB As String
        firstB = arrB(1)
        lastB = arrB(countB)
        
        Dim digits1 As String, digits2 As String
        digits1 = ExtractLast8Digits(firstB)
        digits2 = ExtractLast8Digits(lastB)
        
        Dim resultB As String
        resultB = digits1 & "-" & digits2
        
        ' Определяем, находимся ли мы в таблице
        If Selection.Information(wdWithInTable) Then
            ' Переходим в соседнюю ячейку справа
            Selection.MoveRight Unit:=wdCell
            ' Вставляем результат
            Selection.TypeText Text:=resultB
            ' Форматируем
            With Selection.Font
                .Name = "Times New Roman"
                .Size = 11
                .Bold = False
            End With
        Else
            ' Не в таблице – вставляем через табуляцию на той же строке
            Selection.TypeParagraph
            Selection.TypeText Text:=resultB
            With Selection.Font
                .Name = "Times New Roman"
                .Size = 11
                .Bold = False
            End With
        End If
    End If
    
    ' 10. Завершаем отмену
    undoRec.EndCustomRecord
End Sub

' Функция извлечения последних 8 цифр из строки
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