---

Option Explicit

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

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

    ' --- 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
        ' Если HTML не поддерживается, пробуем Unicode-текст
        wsTemp.PasteSpecial Format:="Текст в кодировке Юникод", Link:=False
    End If
    On Error GoTo 0

    ' --- 4. Проверяем, вставилась ли хоть одна ячейка ---
    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

    ' --- 5. Определяем реальный размер таблицы (без пустых «хвостов») ---
    ' Ищем последнюю строку и столбец с любыми данными
    Dim lastRow As Long, lastCol As Long
    On Error Resume Next
    Set lastCell = wsTemp.Cells.Find("*", wsTemp.Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Not lastCell Is Nothing Then lastRow = lastCell.Row Else lastRow = 1
    Set lastCell = wsTemp.Cells.Find("*", wsTemp.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
    If Not lastCell Is Nothing Then lastCol = lastCell.Column Else lastCol = 1
    On Error GoTo 0

    rowCount = lastRow
    colCount = lastCol
    ' Формируем чистый диапазон таблицы
    Set tblRange = wsTemp.Range(wsTemp.Cells(1, 1), wsTemp.Cells(rowCount, colCount))

    ' --- 6. Копируем этот диапазон в буфер обмена (теперь это Excel-диапазон) ---
    tblRange.Copy

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

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

    ' --- 9. Вставляем таблицу из буфера обмена в активную ячейку ---
    '     Используем Paste (равносильно Ctrl+V) — надёжнее для сохранения оформления.
    On Error Resume Next
    rngStart.Paste
    If Err.Number <> 0 Then
        ' Аварийная вставка хотя бы значений
        rngStart.PasteSpecial Paste:=xlPasteValues
    End If
    On Error GoTo 0

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

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