---

Option Explicit

Sub PasteWordTable()
    ' Надёжная вставка таблицы из Word (из буфера обмена) с автосдвигом строк.
    ' Форматирование и объединённые ячейки сохраняются.

    Dim rngStart As Range
    Dim wsTarget As Worksheet
    Dim wsTemp As Worksheet
    Dim rowCount As Long, colCount As Long
    Dim tblRange As Range

    ' 1. Проверка активной ячейки
    If ActiveCell Is Nothing Then
        MsgBox "Выделите ячейку, куда нужно вставить таблицу.", vbExclamation
        Exit Sub
    End If
    Set rngStart = ActiveCell
    Set wsTarget = rngStart.Worksheet

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ' 2. Создаём временный скрытый лист
    On Error Resume Next
    Set wsTemp = ThisWorkbook.Worksheets("TempForWordTable")
    If Not wsTemp Is Nothing Then
        Application.DisplayAlerts = False
        wsTemp.Delete
        Application.DisplayAlerts = True
    End If
    On Error GoTo 0
    Set wsTemp = ThisWorkbook.Worksheets.Add
    wsTemp.Name = "TempForWordTable"
    wsTemp.Visible = xlSheetHidden

    ' 3. Вставляем таблицу на временный лист (как HTML) для замера размера
    On Error Resume Next
    wsTemp.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
    If Err.Number <> 0 Then
        wsTemp.PasteSpecial Format:="Текст в кодировке Юникод", Link:=False
    End If
    On Error GoTo 0

    ' Проверяем, что данные вставились
    If wsTemp.UsedRange.Cells.Count = 1 And IsEmpty(wsTemp.Range("A1")) Then
        Application.DisplayAlerts = False
        wsTemp.Delete
        Application.DisplayAlerts = True
        MsgBox "Буфер обмена пуст или не содержит таблицу." & vbNewLine & _
               "Скопируйте таблицу в Word (Ctrl+C) и повторите.", vbCritical
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Exit Sub
    End If

    ' 4. Определяем реальный размер таблицы
    Dim lastCell As Range
    Set lastCell = wsTemp.Cells.SpecialCells(xlCellTypeLastCell)
    rowCount = lastCell.Row
    colCount = lastCell.Column
    Set tblRange = wsTemp.Range(wsTemp.Cells(1, 1), wsTemp.Cells(rowCount, colCount))

    ' 5. Копируем вставленный Excel-диапазон обратно в буфер обмена
    tblRange.Copy
    ' Теперь в буфере – Excel-таблица с сохранёнными объединениями

    ' 6. Удаляем временный лист (буфер обмена остаётся нетронутым)
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True

    ' 7. Вставляем пустые строки на целевом листе (сдвигаем всё вниз)
    If rowCount > 0 Then
        rngStart.Resize(rowCount).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If

    ' 8. Вставляем таблицу из буфера обмена в активную ячейку
    rngStart.Select
    On Error Resume Next
    wsTarget.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    If Err.Number <> 0 Then
        wsTarget.Paste ' запасной вариант
    End If
    On Error GoTo 0

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    MsgBox "Таблица успешно вставлена.", vbInformation
End Sub