Макрос переноса строк

[Extril]

Добрый день коллеги, у меня возникла задача: Найти в столбце "i" на всех листах книги "не пустые" ячейки (заполнение происходит по выпадаемому списку) и перенести содержащие такие ячейки строки целиком в лист "макро-регион". Обьем книги будет постоянно расти до 3000 строк.
К сожалению найденные на форуме решения не подходят для моей задачи, поэтому обращаюсь к вам за помощью, и прикрепляю свой файл

[IgorGO]

кнопка "БАНЗАЙ!" на листе "макро-регион"

[Extril]

Спасибо большое, а возможно реализовать функцию переноса (а не копирования)

[IgorGO]

перенос - это в смысле:
вырезать с исходного листа?
или перенести только данные без форматов, формул, проверок и прочего?

[Extril]

Имеется в виду вырезать с исходных листов и поместить в лист "Макро-Регион".
В итоге должен получиться лист с отработанной инфой ("Макро-Регион"), а остальных листах остались лишь рабочие данные (пустой столбец "i").

[IgorGO]

замените
.Rows(R).Copy
на
.Rows(R).Cut

[Extril]

Спасибо, это именно то, что нужно

[masterenergy]

Чтобы не создавать лишней темы решил написать здесь, так как в принципе задача идентична но:
1. Как из листа "цех №1" копировать в лист "сюда цех№1 " строки с тем условием, что если номера из листа "цех №1" не совпадают с номерами в листе "список рн" в 1-ом столбце.
2. всё также только вместо "цех №1" идёт "цех №2"

[IgorGO]

masterenergy, добавите в проект модуль, скопируйте в него этот

Sub StartProc()
  CopySTR Sheets("цех №1").Index, Sheets("сюда цех №1").Index
  CopySTR Sheets("цех №2").Index, Sheets("сюда цех №2").Index
End Sub


Sub CopySTR(ShT As Integer, ShD As Integer)
  Dim RD As Long, r As Long, fnd As Long
  Sheets(ShT).Activate
  With Sheets(ShD)
    RD = .Cells(.Rows.Count, 1).End(xlUp).Row
    For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
      On Error Resume Next
      fnd = WorksheetFunction.Match(Cells(r, 2), Sheets("список рн").Columns(1), 0)
      If Err.Number <> 0 Then
        Err.Clear
        RD = RD + 1
        .Cells(RD, 1) = Cells(r, 1)
        .Cells(RD, 2) = Cells(r, 2)
      End If
    Next
  End With
End Sub

придумайте сами как стартовать StartProc.
новые данные дописываются на листы "сюда цех№..."

[VictorM]

2 masterenergy
Категорически НЕ рекомендую пробелы в имени рабочего листа, были замечены проблемы.
Лучше напишите так:
СюдаЦех№1
или
сюда_цех_№1