---

Option Explicit

' Константы Word для позднего связывания
Private Const wdAlignParagraphLeft = 0
Private Const wdAlignParagraphCenter = 1
Private Const wdAlignParagraphRight = 2
Private Const wdAlignParagraphJustify = 3
Private Const wdCellAlignVerticalTop = 0
Private Const wdCellAlignVerticalCenter = 1
Private Const wdCellAlignVerticalBottom = 2
Private Const wdLineStyleSingle = 1
Private Const wdLineStyleDotted = 2
Private Const wdLineStyleDashed = 3
Private Const wdLineStyleDotDash = 4
Private Const wdLineStyleDouble = 5
Private Const wdColorAutomatic = -16777216
Private Const wdUnderlineNone = 0

Sub ImportWordTableToActiveCell()
    ' Импорт выделенной в Word таблицы на текущий лист Excel,
    ' начиная с активной ячейки.
    ' Автоматически добавляет строки, если их недостаточно,
    ' и подгоняет высоту строк под содержимое.

    Dim wdApp As Object, wdDoc As Object
    Dim wdTable As Object
    Dim ws As Worksheet
    Dim startCell As Range
    Dim startRow As Long, startCol As Long
    Dim maxRows As Long, maxCols As Long
    Dim colWidths() As Single, rowHeights() As Single
    Dim cell As Object
    Dim r0 As Long, c0 As Long, rowSpan As Long, colSpan As Long
    Dim cellText As String
    Dim i As Long, j As Long, k As Long
    Dim sumWidth As Single, sumHeight As Single
    Const TOLERANCE As Single = 2

    ' --- Подключаемся к открытому Word ---
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        MsgBox "Word не запущен. Откройте Word с нужным документом и таблицей.", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    Set wdDoc = wdApp.ActiveDocument
    If wdDoc Is Nothing Then
        MsgBox "Нет активного документа Word.", vbExclamation
        Exit Sub
    End If

    ' Проверяем, что курсор внутри таблицы
    If Not wdApp.Selection.Information(12) Then ' wdWithInTable
        MsgBox "Выделите таблицу или установите курсор внутрь неё в Word.", vbExclamation
        Exit Sub
    End If
    Set wdTable = wdApp.Selection.Tables(1)

    ' --- Текущий лист и активная ячейка ---
    Set ws = ActiveSheet
    Set startCell = ActiveCell
    If startCell Is Nothing Then
        MsgBox "Выделите ячейку на листе Excel, с которой начнётся вставка.", vbExclamation
        Exit Sub
    End If
    startRow = startCell.Row
    startCol = startCell.Column

    maxRows = wdTable.Rows.Count
    maxCols = wdTable.Columns.Count
    If maxRows = 0 Or maxCols = 0 Then Exit Sub

    ' --- Добавляем строки и столбцы, если не хватает ---
    Dim needRows As Long, needCols As Long
    needRows = startRow + maxRows - 1
    needCols = startCol + maxCols - 1
    If needRows > ws.Rows.Count Then
        ws.Rows(ws.Rows.Count).Resize(needRows - ws.Rows.Count).Insert Shift:=xlDown
    End If
    If needCols > ws.Columns.Count Then
        ' Обычно столбцов хватает, но на всякий случай
        ws.Columns(ws.Columns.Count).Resize(, needCols - ws.Columns.Count).Insert Shift:=xlToRight
    End If

    ' Запоминаем ширины столбцов и высоты строк Word
    ReDim colWidths(1 To maxCols)
    For j = 1 To maxCols
        colWidths(j) = wdTable.Columns(j).Width
    Next j
    ReDim rowHeights(1 To maxRows)
    For i = 1 To maxRows
        rowHeights(i) = wdTable.Rows(i).Height
    Next i

    Application.ScreenUpdating = False

    ' --- Перенос ячеек с учётом смещения startRow, startCol ---
    For Each cell In wdTable.Range.Cells
        r0 = cell.RowIndex
        c0 = cell.ColumnIndex

        ' Горизонтальное объединение
        sumWidth = 0
        colSpan = 0
        For k = c0 To maxCols
            sumWidth = sumWidth + colWidths(k)
            If sumWidth >= cell.Width - TOLERANCE Then
                colSpan = k - c0 + 1
                Exit For
            End If
        Next k
        If colSpan = 0 Then colSpan = 1

        ' Вертикальное объединение
        sumHeight = 0
        rowSpan = 0
        For k = r0 To maxRows
            sumHeight = sumHeight + rowHeights(k)
            If sumHeight >= cell.Height - TOLERANCE Then
                rowSpan = k - r0 + 1
                Exit For
            End If
        Next k
        If rowSpan = 0 Then rowSpan = 1

        ' Чистый текст (убираем символ конца ячейки)
        cellText = cell.Range.Text
        If Len(cellText) >= 2 Then
            cellText = Left(cellText, Len(cellText) - 2)
        End If

        ' Адрес в Excel с учётом смещения
        Dim exRange As Range
        Set exRange = ws.Range( _
            ws.Cells(startRow + r0 - 1, startCol + c0 - 1), _
            ws.Cells(startRow + r0 - 1 + rowSpan - 1, startCol + c0 - 1 + colSpan - 1))

        With exRange
            .Merge
            .Value = cellText

            ' Шрифт
            .Font.Name = cell.Range.Font.Name
            .Font.Size = cell.Range.Font.Size
            .Font.Bold = cell.Range.Font.Bold
            .Font.Italic = cell.Range.Font.Italic
            .Font.Underline = (cell.Range.Font.Underline <> wdUnderlineNone)
            If cell.Range.Font.Color <> wdColorAutomatic Then
                .Font.Color = cell.Range.Font.Color
            End If

            ' Выравнивание
            Select Case cell.Range.ParagraphFormat.Alignment
                Case wdAlignParagraphCenter: .HorizontalAlignment = xlHAlignCenter
                Case wdAlignParagraphRight:  .HorizontalAlignment = xlHAlignRight
                Case wdAlignParagraphJustify: .HorizontalAlignment = xlHAlignJustify
                Case Else: .HorizontalAlignment = xlHAlignLeft
            End Select

            Select Case cell.VerticalAlignment
                Case wdCellAlignVerticalCenter: .VerticalAlignment = xlVAlignCenter
                Case wdCellAlignVerticalBottom: .VerticalAlignment = xlVAlignBottom
                Case Else: .VerticalAlignment = xlVAlignTop
            End Select

            .WrapText = True

            ' Заливка
            On Error Resume Next
            If cell.Shading.BackgroundPatternColor <> wdColorAutomatic And _
               cell.Shading.BackgroundPatternColor <> 16777215 Then
                .Interior.Color = cell.Shading.BackgroundPatternColor
            End If
            On Error GoTo 0

            ' Границы
            ApplyBorders cell, .Cells
        End With
    Next cell

    ' Ширина столбцов (пропорционально Word)
    For j = 1 To maxCols
        ws.Columns(startCol + j - 1).ColumnWidth = colWidths(j) * 0.7
    Next j

    ' АВТОПОДБОР ВЫСОТЫ СТРОК ПОД СОДЕРЖИМОЕ
    ws.Rows(startRow & ":" & startRow + maxRows - 1).AutoFit

    Application.ScreenUpdating = True
    MsgBox "Таблица вставлена, начиная с ячейки " & startCell.Address(False, False) & ".", vbInformation
End Sub

' Перенос границ
Private Sub ApplyBorders(wdCell As Object, exRange As Range)
    Dim wdBorder As Object
    Dim wdStyle As Long
    Dim exLineStyle As XlLineStyle
    Dim exWeight As XlBorderWeight
    Dim exColor As Long

    On Error Resume Next
    Set wdBorder = wdCell.Borders(2) ' wdBorderLeft
    If Not wdBorder Is Nothing Then
        wdStyle = wdBorder.LineStyle
        If wdStyle = 0 Then
            exRange.Borders.LineStyle = xlNone
        Else
            exLineStyle = ConvertLineStyle(wdStyle)
            exWeight = ConvertWeight(wdBorder.LineWidth)
            exColor = wdBorder.Color
            With exRange.Borders
                .LineStyle = exLineStyle
                .Weight = exWeight
                .Color = exColor
            End With
        End If
    End If
    On Error GoTo 0
End Sub

Private Function ConvertLineStyle(wdStyle As Long) As XlLineStyle
    Select Case wdStyle
        Case wdLineStyleSingle: ConvertLineStyle = xlContinuous
        Case wdLineStyleDotted: ConvertLineStyle = xlDot
        Case wdLineStyleDashed, wdLineStyleDotDash: ConvertLineStyle = xlDash
        Case wdLineStyleDouble: ConvertLineStyle = xlDouble
        Case Else: ConvertLineStyle = xlNone
    End Select
End Function

Private Function ConvertWeight(widthPt As Single) As XlBorderWeight
    If widthPt <= 1 Then
        ConvertWeight = xlThin
    ElseIf widthPt <= 2 Then
        ConvertWeight = xlMedium
    Else
        ConvertWeight = xlThick
    End If
End Function