Нашел на одном из форумов кусочек кода, который позволяет выбрать необходимый диапазон ячеек (в моем случае это ячейка 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
Все просто замечательно! Огромное спасибо!