Sub InsertWithAutoNumbering()
Dim rngCopy As Range ' Скопированный диапазон
Dim targetCell As Range ' Ячейка для вставки (активная)
Dim startRow As Long ' Строка начала вставки
Dim rowsCount As Long ' Количество строк в скопированном диапазоне
Dim i As Long ' Счётчик
Dim nextNum As Long ' Следующий порядковый номер
Dim rngAbove As Range ' Диапазон выше места вставки в столбце A
' 1. Проверка: есть ли данные в буфере обмена (режим копирования)
If Application.CutCopyMode <> xlCopy Then
MsgBox "Сначала скопируйте нужные ячейки (Ctrl+C), а затем выполните макрос.", _
vbExclamation, "Буфер пуст"
Exit Sub
End If
' 2. Запоминаем скопированный диапазон и активную ячейку (место вставки)
Set rngCopy = Selection
If rngCopy Is Nothing Then
MsgBox "Не удалось определить скопированный диапазон.", vbExclamation, "Ошибка"
Exit Sub
End If
rowsCount = rngCopy.Rows.Count ' сколько строк будет добавлено
Set targetCell = ActiveCell ' место вставки (верхняя левая ячейка)
startRow = targetCell.Row
' 3. Вставляем скопированные ячейки со сдвигом существующих вниз
' (автоматически добавится ровно rowsCount строк в нужных столбцах)
targetCell.Insert Shift:=xlDown
' 4. Отключаем "бегущую рамку" копирования
Application.CutCopyMode = False
' 5. Вычисляем, с какого номера продолжить нумерацию в столбце A
nextNum = 1
If startRow > 1 Then
Set rngAbove = Range("A1:A" & startRow - 1)
' Проверяем, есть ли числовые значения выше
If Application.WorksheetFunction.Count(rngAbove) > 0 Then
nextNum = Application.WorksheetFunction.Max(rngAbove) + 1
End If
End If
' 6. Заполняем столбец A порядковыми номерами для всех новых строк
For i = 1 To rowsCount
Cells(startRow + i - 1, 1).Value = nextNum + i - 1
Next i
MsgBox "Готово! Вставлено " & rowsCount & " строк с нумерацией.", vbInformation, "Успех"
End Sub