Строки, строки

[Trimbl]

Здавствуйте Все!
Столько о них(строках)говорено и все равно возник вопрос.
В прилагаемом файле есть кнопка "Новый участок" запускающая макрос "NewUshastok".
Вопрос: 1. Как в вновь созданном блоке удалить диапазон строк с 17 по 19 включительно(количество строк не постоянно). В столбцах А и В ячейки объеденены(что меня и тупит).
2.Будьте добры, объясните почему в моем примере такой код копирования и вставки строк не работает

Sub NewUshastok()

Dim i As Long, j As Long
Application.ScreenUpdating = False

i = Cells(Rows.Count, 1).End(xlUp).Row
j = i - Cells(i - 2, 1).MergeArea.Rows.Count
Rows(i + 1 & ":" & j).Copy 'Копирует диапазонстрок не с 10 а, с 11 строки в приведенном примере
Rows(i).Insert 'Выдает ошибку Run-time error 1004
Application.ScreenUpdating = True
End Sub
Спасибо.

[nilem]

Так попробуйте:

Sub NewUshastok()
Dim i As Long, j As Long, rng As Range
Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(Cells(i - 2, 1).MergeArea, Cells(i + 1, 1))
rng.EntireRow.Copy Cells(i, 1)
j = Cells(Rows.Count, 1).End(xlUp).Row
Cells(j - 4, 3) = 1: Cells(j - 3, 3) = 2
If rng.Count > 6 Then Range(Cells(j - 5, 1), Cells(i, 1)).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Оставляем две строки, чтобы формулы не сбились.

[Trimbl]

Сообщение от nilem

Так попробуйте:

Sub NewUshastok()
Dim i As Long, j As Long, rng As Range
Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(Cells(i - 2, 1).MergeArea, Cells(i + 1, 1))
rng.EntireRow.Copy Cells(i, 1)
j = Cells(Rows.Count, 1).End(xlUp).Row
Cells(j - 4, 3) = 1: Cells(j - 3, 3) = 2
If rng.Count > 6 Then Range(Cells(j - 5, 1), Cells(i, 1)).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Оставляем две строки, чтобы формулы не сбились.

nilem, попробовал, все ОК. Извиняюсь за долгое отсутствие,- был в пути. Спасибо.

[Trimbl]

Сообщение от Trimbl

nilem, попробовал, все ОК. Извиняюсь за долгое отсутствие,- был в пути. Спасибо.

Уважаемый nilem, извиняюсь, но самоуверенность подвела. Добавил в Ваш код две строки с целью нумерации участков(столбец А). В подобных кодах работает, а тут хоть плачь и не туды и не сюды. Будьте добры, - посмотрите.
Sub NewUshastok()
Dim i As Long, j As Long, n As Long, rng As Range
Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(Cells(i - 2, 1).MergeArea, Cells(i + 1, 1))
rng.EntireRow.Copy Cells(i, 1)
n = Cells(i - 2, 1)
j = Cells(Rows.Count, 1).End(xlUp).Row
Cells(j - 4, 3) = 1: Cells(j - 3, 3) = 2
If rng.Count > 6 Then Range(Cells(j - 5, 1), Cells(i, 1)).EntireRow.Delete
Cells(i, 1) = n + 1
Application.ScreenUpdating = True
End Sub

[nilem]

С объединенными ячейками всегда проблемы. Пробуйте так:

Sub NewUshastok()
Dim i As Long, j As Long, n As Long, rng As Range
Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
n = Cells(i - 2, 1).MergeArea.Cells(1, 1).Value
Set rng = Range(Cells(i - 2, 1).MergeArea, Cells(i + 1, 1))
rng.EntireRow.Copy Cells(i, 1)
j = Cells(Rows.Count, 1).End(xlUp).Row
If rng.Count > 6 Then Range(Cells(j - 5, 1), Cells(i, 1)).EntireRow.Delete
Cells(i, 3) = 1: Cells(i + 1, 3) = 2: Cells(i, 1) = n + 1
Application.ScreenUpdating = True
End Sub

[Trimbl]

Сообщение от nilem

С объединенными ячейками всегда проблемы. Пробуйте так:

Sub NewUshastok()
Dim i As Long, j As Long, n As Long, rng As Range
Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
n = Cells(i - 2, 1).MergeArea.Cells(1, 1).Value
Set rng = Range(Cells(i - 2, 1).MergeArea, Cells(i + 1, 1))
rng.EntireRow.Copy Cells(i, 1)
j = Cells(Rows.Count, 1).End(xlUp).Row
If rng.Count > 6 Then Range(Cells(j - 5, 1), Cells(i, 1)).EntireRow.Delete
Cells(i, 3) = 1: Cells(i + 1, 3) = 2: Cells(i, 1) = n + 1
Application.ScreenUpdating = True
End Sub

nilem, благодаря Вам, сделан еще один шаг в познании необходимого минимума, для создания документов Excel средствами VBA. Спасибо