---

Option Explicit

Sub PasteWordColumnWithRowInsert()
    ' Макрос для вставки данных из буфера обмена (скопированных из Word)
    ' с автоматической вставкой строк по количеству строк данных.
    
    Dim targetCell As Range
    Dim tempWS As Worksheet
    Dim pastedRange As Range
    Dim rowCount As Long
    Dim colCount As Long
    Dim dataRange As Range
    
    ' Отключаем обновление экрана и предупреждения для скорости
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Запоминаем активную ячейку (место вставки)
    On Error Resume Next
    Set targetCell = ActiveCell
    On Error GoTo 0
    If targetCell Is Nothing Then
        MsgBox "Сначала выделите ячейку, куда нужно вставить данные.", vbExclamation
        GoTo CleanUp
    End If
    
    ' Проверяем, есть ли что-то в буфере обмена
    If Application.CutCopyMode = False Then
        ' Можно проверить через DataObject, но проще попробовать вставить
        ' Если в буфере пусто, то вставка вызовет ошибку, обработаем её
    End If
    
    ' Создаём временный лист для анализа скопированных данных
    Set tempWS = ThisWorkbook.Worksheets.Add
    tempWS.Visible = xlSheetHidden ' скрываем, чтобы не мелькало
    
    ' Пытаемся вставить данные из буфера на временный лист
    On Error Resume Next
    tempWS.Paste Destination:=tempWS.Range("A1")
    If Err.Number <> 0 Then
        MsgBox "Не удалось вставить данные из буфера обмена." & vbCrLf & _
               "Убедитесь, что вы скопировали ячейки из Word.", vbCritical
        tempWS.Delete
        GoTo CleanUp
    End If
    On Error GoTo 0
    
    ' Определяем диапазон вставленных данных
    If tempWS.UsedRange.Cells.Count = 1 And IsEmpty(tempWS.Range("A1")) Then
        MsgBox "Буфер обмена пуст.", vbExclamation
        tempWS.Delete
        GoTo CleanUp
    End If
    
    ' Берём текущую область вокруг A1 (вдруг там несколько столбцов)
    Set pastedRange = tempWS.Range("A1").CurrentRegion
    rowCount = pastedRange.Rows.Count
    colCount = pastedRange.Columns.Count
    
    ' Если скопировано всего одна ячейка, CurrentRegion может не сработать
    If rowCount = 1 And colCount = 1 Then
        ' Проверим, есть ли данные в A1
        If Not IsEmpty(tempWS.Range("A1")) Then
            rowCount = 1
            colCount = 1
            Set pastedRange = tempWS.Range("A1")
        Else
            ' Странная ситуация
            tempWS.Delete
            GoTo CleanUp
        End If
    End If
    
    ' Переходим на исходный лист и вставляем строки
    targetCell.Worksheet.Activate
    targetCell.Select
    
    ' Вставляем нужное количество строк, сдвигая существующие вниз
    ' Если targetCell не в первой строке, вставляем строки начиная с неё
    If rowCount > 0 Then
        targetCell.Resize(rowCount).EntireRow.Insert Shift:=xlDown, _
            CopyOrigin:=xlFormatFromLeftOrAbove
    End If
    
    ' Копируем данные с временного листа и вставляем с сохранением формата
    pastedRange.Copy
    targetCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    ' Удаляем временный лист
    tempWS.Delete
    
    MsgBox "Готово! Вставлено строк: " & rowCount & ", столбцов: " & colCount, vbInformation
    
CleanUp:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub