---

Option Explicit

Sub PasteWordTable()
    ' Вставка таблицы из Word с автосдвигом строк и сохранением форматирования.
    ' Перед запуском таблица должна быть скопирована в Word (Ctrl+C).

    Dim rngStart As Range, wsTarget As Worksheet
    Dim wsTemp As Worksheet
    Dim tblRange As Range
    Dim rowCount As Long, colCount As Long
    Dim lastRow As Long, lastCol 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
        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. Определяем реальный диапазон таблицы (без пустых строк/столбцов) ---
    On Error Resume Next
    lastRow = wsTemp.Cells.Find("*", wsTemp.Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
    lastCol = wsTemp.Cells.Find("*", wsTemp.Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
    On Error GoTo 0
    If lastRow = 0 Then lastRow = 1
    If lastCol = 0 Then lastCol = 1
    rowCount = lastRow
    colCount = lastCol
    Set tblRange = wsTemp.Range(wsTemp.Cells(1, 1), wsTemp.Cells(rowCount, colCount))

    ' --- 5. Копируем эту таблицу как Excel-диапазон в буфер обмена ---
    tblRange.Copy

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

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

    ' --- 8. Только теперь удаляем временный лист ---
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True

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

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