ограничить количество строк

[vostok]

Добрый вечер друзья. Всех с Новым Годом!
Прошу помощи, здесь мне однажды написали код для вставки в последнюю пустую строку, успешно им пользуюсь, вот он:

ActiveSheet.Unprotect
[b4:j13].Copy
Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("f4:f13,b4:b13,g5:g13").Selec t
Selection.ClearContents
Range("H4").Select
ActiveCell.FormulaR1C1 = "=RC[23]"
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowSorting:=True, AllowFiltering:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Range("b4").Select
End Sub

Вопрос такой: а нельзя изменить выделенную часть кода, чтобы он искал пустую строку не до конца листа (66 с лишним тысяч строк ведь), а лишь, допустим, до 4000-й строки? Мне кажется, это ускорит выполнение кода, или ошибаюсь?
Оптимизирую сейчас рабочие книги, вот, задумался...

[Скрипт]

vostok, я сделал циклы со 100 000 итерациями (витками) и разница оказалась в 0,2 секунды. Т.е. эту часть кода можно не оптимизировать.

Вам нужно избавиться от копирования и вставки. Копирование и вставку нужно делать, если нужно перенести форматирование текста (например, название шрифта, жирность текста) или если нужно что-то ещё перенести кроме данных.

И нужно избавиться от Select.

[vostok]

Как избавиться? Это основная операция по сбору данных, как ее иначе сделать, если не через копипаст. И select чем не угодил? Надо избирательно очистить столбцы.

[Казанский]

Этот кусок следует переписать так:

ActiveSheet.Unprotect
Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Resize(10, 9).Value = [b4:j13].Value
Range("f4:f13,b4:b13,g5:g13").ClearContents
Range("H4").FormulaR1C1 = "=RC[23]"
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowSorting:=True, AllowFiltering:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Range("b4").Select 'надо ли?

[Serge 007]

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

...select чем не угодил?

Селекты тормозят код

Без них, но с копированием:

Sub vostok()
 ActiveSheet.Unprotect
  [b4:j13].Copy
  Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
   Range("f4:f13,b4:b13,g5:g13").ClearContents
   Range("H4").FormulaR1C1 = "=RC[23]"
  ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
  False, AllowSorting:=True, AllowFiltering:=True
 ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

[vostok]

Парни, спасибо, опробовал оба кода, от Казанского - супер, очень быстро, я даже не вижу выделения вставляемой таблицы, но у меня шустрый комп, а работа на слабых машинах, проверю там завтра. Селект "b4" - надо, курсор после очистки должен установиться в начальную ячейку для ввода. Код от Сергея тормозит, выполняется 5 секунд
Спасибо за отзывчивость!

[Serge 007]

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

Код от Сергея тормозит, выполняется 5 секунд

Это ВАШ код, я только убрал селекты
Скрипт советовал ещё "избавиться от копирования и вставки" (что и сделал Казанский)
Результат видите?

[vostok]

Проверил, все просто замечательно, работает быстро, как и хотелось. Нет видимого выделения пока таблицы, потом места для нее в нижнем списке. Спасибо еще раз!