Формирование новых таблиц для каждой строки из одной таблицы по критерию

Option Explicit
 
Sub Copy_Table_if()
Dim RSy%, REy%, RSx%, REx% 'Read
Dim WSy%, WCy%, WSx%, WCx% 'Write
Dim X%, Y% 'cycle
Dim Request$, FirstTime As Boolean
'определение границ таблицы (привязка к начальной ячейке B2)
With [B2]
  RSy = .Row + 1
  REy = .End(xlDown).Row 'Last Row
  RSx = .Column + 1 'Column "C"
  REx = .End(xlToRight).Column 'Last Column
End With
Request = Range("Criteria") 'Условие в именованной ячейке (Ctrl+F3)
With Range("Result") 'Результат записывать, начиная с именованной ячейки "Result"
  WSy = .Row + 1 'Start
  WCy = WSy 'Current
  WSx = .Column + 1 'Start
  WCx = WSx 'Current
End With
For Y = RSy To REy
  For X = RSx To REx
    If Evaluate(Cells(Y, X).Value & Request) Then
      If Not FirstTime Then 'первое значение нашли - создаем таблицу
        FirstTime = True
        Cells(WCy, WCx).Offset(-1, -1).Value = "ID"
        Cells(WCy, WCx).Offset(0, -1).Value = Cells(Y, RSx - 1).Value
      End If
      Cells(WCy, WCx).Offset(-2, 0).Value = Cells(RSy, X).Offset(-2, 0).Value
      Cells(WCy, WCx).Offset(-1, 0).Value = Cells(RSy, X).Offset(-1, 0).Value
      Cells(WCy, WCx).Value = Cells(Y, X).Value
      WCx = WCx + 1
    End If
  Next X
  'Если были совпадения, делаем промежуток между таблицами результатов
  If FirstTime Then FirstTime = False: WCx = WSx: WCy = WCy + 4
Next Y
End Sub