[EXCEL VBA]

Witajcie, mam taki niewielki problem ale utknąłem. Mam kod który ma dzielić określony zakres na arkusze zgodnie z określonym kryterium

Sub DzielenieNaArkusze()
Dim Table As ListObject
Dim SortColumn As ListColumn
Dim CriteriaColumn As ListColumn
Dim FoundRange As Range
Dim TargetSheet As Worksheet
Dim HeaderVisible As Boolean

Set Table = ActiveSheet.ListObjects(1)
HeaderVisible = Table.ShowHeaders
Table.ShowHeaders = True

On Error GoTo RemoveColumns
Set SortColumn = Table.ListColumns.Add(Table.ListColumns.Count + 1)
Set CriteriaColumn = Table.ListColumns.Add(Table.ListColumns.Count + 1)
On Error GoTo 0

SortColumn.Name = " Sort"
CriteriaColumn.Name = " Criteria"
SortColumn.DataBodyRange.Formula = "=ROW(A1)"
SortColumn.DataBodyRange.Value = SortColumn.DataBodyRange.Value

CriteriaColumn.DataBodyRange.Formula = "=1/(({@Units]<10)*([@Cost]<5))"
CriteriaColumn.DataBodyRange.Value = CriteriaColumn.DataBodyRange.Value

Table.Range.Sort Key1:=CriteriaColumn.Range(1, 1), Order1:=xlAscending, Header:=xlYes
On Error Resume Next
Set FoundRange = Intersect(Table.Range, CriteriaColumn.DataBodyRange.SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow)
On Error GoTo 0
If Not FoundRange Is Nothing Then
    Set TargetSheet = ThisWorkbook.Worksheets.Add(After:=ActiveSheet)
        FoundRange(1, 1).Offset(-1, 0).Resize(FoundRange.Rows.Count + 1, FoundRange.Columns.Count - 2).Copy
    TargetSheet.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
End If
Table.Range.Sort Key1:=CriteriaColumn.Range(1, 1), Order1:=xlAscending, Header:=xlYes

RemoveColumns:
If Not SortColumn Is Nothing Then SortColumn.Delete
If Not CriteriaColumn Is Nothing Then CriteriaColumn.Delete
Table.ShowHeaders = HeaderVisible
End Sub

Kod wywala się na linijce Set Table = ActiveSheet.ListObjects(1)
Z komunikatem Subscript out of range

Nie mogę znaleźć przyczyny.
pomóżcie proszę :)