---

Option Explicit

Sub PasteWordTable()
    ' Вставка таблицы из Word (из буфера обмена) в Excel с автосдвигом строк.
    ' Сохраняет объединённые ячейки, цвета, границы и шрифты.

    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

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

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

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