Excel VBA Макросы: Вставка заданного количества строк после выделенных ячеек и заполнение их данными.

[AlekseyUkhin]

Нашел на одном из форумов кусочек кода, который позволяет выбрать необходимый диапазон ячеек (в моем случае это ячейка D14 Название проекта, как говорил выше, их может быть рандомное кол-во, т.е. D14, 15 итд) и добавить после каждой заполненной строки 6 пустых и итд, пока не закончиться цикл.

Код:

Sheets("Н1 (сокр)").Select
Dim rng As Range
Set rng = Application.InputBox("Выделите диапазон", , , , , , , 8)
a = rng.row
b = a + rng.Rows.Count - 1
For i = b To a + 1 Step -1
Rows(i & ":" & i + 5).Insert
Next


это все круто и работает. но теперь необходио заполнить эти новые строки информацией (колонка J, комментарий) информация для всех проектов будет одна и та же:
1.Дорожная карта реализации проекта
2.График 1-го уровня
3.График 2-го, 3 уровня
4.График 4 уровня
5.МДР
6.План по управлению качество
7.Программа ИИ

Нужно чтобы при выборе диапазона и добавлении пустых строк, строки колонки J заполнялись значениями которые я написал выше, так же по циклу.

Лист "Н1 (сокр)" это изначальный вариант, а лист "готово" это как должно выглядеть в идеале.

[вложение удалено администратором]

[Администратор]

Запустите макрос, выберите на листе "Н1 (сокр)" в столбце H ячейки, после которых нужно вставить новые строки.

Макрос

Sub макрос()

    Dim rng As Range, ar As Range, cell As Range, NewRng As Range
    Dim i As Long, ii As Long
   
   
    '1. Юзер выбирает ячейки в нужном столбце, после которых нужно вставить строки.
    On Error Resume Next
    Set rng = Application.InputBox(Prompt:="Выберите ячейки, после которых нужно вставить новые строки:", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then
        Exit Sub
    End If
   
    '2. Отключение пересчёта формул и монитора, чтобы ускорить макрос.
    Dim calc As Long: calc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
   
    '3. Вставка новых строк.
    Application.CutCopyMode = False
    For i = rng.Areas.Count To 1 Step -1
        Set ar = rng.Areas(i)
        For ii = ar.Cells.Count To 1 Step -1
            Set cell = ar.Cells(ii)
            cell.Offset(1, 0).Resize(6).EntireRow.Insert
            Set NewRng = cell.Resize(7)
            NewRng.Cells(1, 1).Value = "1.Дорожная карта реализации проекта"
            NewRng.Cells(2, 1).Value = "2.График 1-го уровня"
            NewRng.Cells(3, 1).Value = "3.График 2-го, 3 уровня"
            NewRng.Cells(4, 1).Value = "4.График 4 уровня"
            NewRng.Cells(5, 1).Value = "5.МДР"
            NewRng.Cells(6, 1).Value = "6.План по управлению качество"
            NewRng.Cells(7, 1).Value = "7.Программа ИИ"
        Next ii
    Next i
   
    '4. Включения.
    Application.Calculation = calc
    Application.ScreenUpdating = True
   
End Sub

[свернуть]

[AlekseyUkhin]

Все просто замечательно! Огромное спасибо!