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

Sub Nik035()
Dim nms As Names ' коллекция именованных диапазонов книги
Dim nm As Name ' текущий именованный диапазон
Dim rng As Range ' диапазон соответствующий именованному диапазону
Dim rw As Integer ' номер строки в именованном диапазоне
Dim cl As Integer ' номер столба в именованном диапазоне
Range("L4:Q200").Select
    Selection.ClearContents
Dim cnt As Integer ' номер строки в сводной спецификации
cnt = 3
For Each nm In Names ' перебор именованных диапазонов
Set rng = Range(nm) ' получение диапазона
    cnt = cnt + 1 '
    rng.Cells(1, 3).Copy Cells(cnt, 14) ' копирование заголовка диапазона
    rng.Cells(1, 4).Copy Cells(cnt, 15) ' копирование *
For rw = 2 To rng.Rows.Count ' перебор диапазона
    If Len(rng.Cells(rw, 4)) > 0 Then ' если в столбце кол. не пусто добавляем строку
        cnt = cnt + 1 '
                   rng.Range(Cells(rw, 1), Cells(rw, 6)).Copy Cells(cnt, 12)
    End If
Next
Next
MsgBox "TheEnd!!!"
End Sub

Sub Nik035()
 Dim nms As Names ' коллекция именованных диапазонов книги
 Dim nm As Name ' текущий именованный диапазон
 Dim rng As Range ' диапазон соответствующий именованному диапазону
 Dim rw As Integer ' номер строки в именованном диапазоне
 Dim sh1 'объект с нашим листом. 
 Set Sh1 = Sheets(1) 'Можно использовать Sheets("ИмяВашегоЛиста")
 Sh1.Range("L4:Q200").ClearContents
 Dim cnt As Integer ' номер строки в сводной спецификации
 cnt = 3
 For Each nm In Names ' перебор именованных диапазонов
   Set rng = Sh1.Range(nm) ' получение диапазона
   cnt = cnt + 1 '
   rng.Cells(1, 3).resize(1,2).Copy Sh1.Cells(cnt, 14) ' копирование заголовка диапазона
   PreRow = 2 'предыдущая непустая строка. Назначим первую проверяемую ею - пусть докажет!
   For rw = 2 To rng.Rows.Count ' перебор диапазона
     If Len(rng.Cells(rw, 4).text) = 0 Then ' если в столбце кол. пусто - копируем все строки между пустотами
       if PreRow < rw Then 'если предыдущая непустая строка не равна текущей - есть что переносить
         rng.Cells(PreRow, 1).resize(rw-PreRow,6).Copy Sh1.Cells(cnt, 12) ' копирование ячеек в сводную спецификацию
         cnt = cnt + rw - PreRow'
       end if
       PreRow = rw + 1'назначим следующую строку непустой. Пусть докажет!
     End If
   Next
   rw =rng.rows.count+1
   if PreRow < rw Then rng.Cells(PreRow, 1).resize(rw-PreRow,6).Copy Sh1.Cells(cnt, 12)
 Next
 
 MsgBox "TheEnd!!!"
End Sub

Sub newMacro()
    Dim iRows As Long, wrkSheet As Worksheet, i As Long
    Dim iRow As Long, bLineBreak As Boolean
    Dim iBegin As Integer, iEnd As Integer
    
    Application.ScreenUpdating = False
    Set wrkSheet = ActiveSheet
    iRows = wrkSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    iRow = 3
    iEnd = 0
    iBegin = 0
    bLineBreak = False
    wrkSheet.Range("L4:Q" & CStr(iRows)).ClearContents
    
    For i = 4 To iRows
       If (((wrkSheet.Cells(i, 6) = "") And (wrkSheet.Cells(i, 5) <> "") And (wrkSheet.Cells(i, 4) <> "")) Or _
          ((wrkSheet.Cells(i, 6) = "") And (wrkSheet.Cells(i, 5) = "") And (wrkSheet.Cells(i, 4) = ""))) Then
          If (iBegin <> 0) Then
             If Not bLineBreak Then iRow = iRow - 1
             wrkSheet.Range("C" & CStr(iBegin) & ":H" & CStr(iEnd)).Copy wrkSheet.Cells(iRow + 1, 12)
             iRow = iRow + iEnd - iBegin + 2
             iBegin = 0
             iEnd = 0
          End If
          bLineBreak = ((wrkSheet.Cells(i, 6) = "") And (wrkSheet.Cells(i, 5) = "") And (wrkSheet.Cells(i, 4) = ""))
       Else
         If (iBegin = 0) Then iBegin = i
         iEnd = i
       End If
    Next i
    If iBegin <> 0 Then wrkSheet.Range("C" & CStr(iBegin) & ":H" & CStr(iEnd)).Copy wrkSheet.Cells(iRow + 1, 12)
    Application.ScreenUpdating = True
End Sub

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