Excel Макрос для копирования информации из одной таблицы в другую по условию - VBA - Ответ 16116921

Sub Nik035()
 Dim nRows, rw, sh1, cnt, iBegin, aa
 Set sh1 = ActiveSheet 'Можно использовать Sheets("ИмяВашегоЛиста")
 nRows = sh1.Cells(sh1.Rows.Count, 13).End(-4162).Row - 3 'число непустых строк результата (без заголовка)
 sh1.Cells(4, 12).Resize(nRows, 6).ClearContents 'чистим прежний результат
 nRows = sh1.Cells(sh1.Rows.Count, 4).End(-4162).Row - 3 'число непустых строк исходника (без заголовка)
 aa = sh1.Cells(4, 3).Resize(nRows, 6).Value 'читаем исходник в массив для ускорения
 cnt = 4 'начальная строка результата
 iBegin = 0 'предыдущая непустая строка исходника (ниже заголовка)
 For rw = 1 To nRows Step 1 'перебираем строки
   If Trim(Cstr(aa(rw, 4))) = "" Then 'если значения нет
     If iBegin <> 0 Then 'если есть что переносить выше
       sh1.Cells(iBegin + 3, 3).Resize(rw - iBegin, 6).Copy sh1.Cells(cnt, 12) 'копирование ячеек в сводную спецификацию
       sh1.Cells(cnt, 15).Resize(rw - iBegin, 1).Value = aa 'копирование значений поверх, чтобы затереть формулы
       cnt = cnt + rw - iBegin 'сдвигаем начальную строку результата для следующего переноса
       iBegin = 0 'очищаем первую непустую строку исходника
     End If
   Else 'Значение есть (пусть даже и скрытое)
     If iBegin = 0 Then iBegin = rw 'установим начальную строку исходника для следующего переноса
     aa(rw - iBegin + 1, 1) = aa(rw, 4) 'перенсём значение в начало массива, чтобы потом затирать этим куском
   End If
 Next
 If iBegin <> 0 Then 'есть ещё последний непустой кусок для переноса
   sh1.Cells(iBegin + 3, 3).Resize(nRows - iBegin+1, 6).Copy sh1.Cells(cnt, 12) ' перенесем и его
   sh1.Cells(cnt, 15).Resize(nRows - iBegin+1, 1).Value = aa 'и затрём формулы значениями
 end if
 MsgBox "TheEnd!!!"
End Sub