Sub qqq_1()
    Dim r0_, r1_, ar1
    Dim oTbl As ListObject
    Set oTbl = Sheets("Лист2").ListObjects("Расчет")
    r0_ = 6
    With Worksheets("Лист1")
        r1_ = .Cells(Rows.Count, 4).End(3).Row
        If r1_ >= r0_ Then
            .Cells(r0_, 4).Resize(r1_ - r0_ + 1, 10).ClearContents
        End If
        With oTbl.Sort
            .SortFields.Clear
            .SortFields.Add oTbl.ListColumns("Направление").Range
            .Apply
        End With
        oTbl.Range.AutoFilter 2, .Range("D2")
        ar1 = oTbl.DataBodyRange.Columns(3).Resize(, 10).SpecialCells(xlVisible)
        .Cells(r0_, 4).Resize(, 10) = oTbl.HeaderRowRange.Columns(3).Resize(, 10).Value
        .Cells(r0_ + 1, 4).Resize(UBound(ar1), 10) = ar1
        oTbl.DataBodyRange.AutoFilter 2
    End With
End Sub

Sub Filtr_()
Dim ar0(), ar1()
Dim sStr As String
Dim i As Long, k As Long, j As Long
Const lRw As Byte = 6
    With Worksheets("Лист2")
        i = .UsedRange.Rows.Count: If i < 2 Then Exit Sub
        ar0 = .Range("C1:N" & i).Value
    End With
    
    ReDim ar1(1 To i, 1 To 10)
        
    With Worksheets("Лист1")
        sStr = .Range("D2").Value
        .Columns(4).Resize(, 10).ClearContents
        .Range("D2").Value = sStr

        For i = 2 To UBound(ar0)
            If ar0(i, 1) = sStr Then
                k = k + 1
                
                For j = 1 To 10
                    ar1(k, j) = ar0(i, j + 1)
                Next j
            End If
        Next i
        
        .Cells(lRw, 4).Resize(k, 10).Value = ar1
    End With
End Sub

Sub tt()
    x_ = Range("D2")
    With Worksheets("Лист2")
        r00_ = .Columns("C:C").Find(x_).Row
        n1_ = WorksheetFunction.CountIf(.Columns("C:C"), x_)
        ar0 = Range("Расчет")
        n0_ = UBound(ar0)
        r0_ = 6
        r1_ = .Cells(Rows.Count, 4).End(3).Row
        If r1_ >= r0_ Then
            Cells(r0_, 4).Resize(r1_ - r0_ + 1, 10).Clear
        End If
        .Cells(r00_, 4).Resize(n1_, 10).Copy Cells(r0_, 4).Resize(n1_, 10)
    End With
End Sub