How can I speed up copying filtered cells to new workbook?

I have code to copy filtered cells to a new workbook. It takes almost two minutes to run. How can I adjust the code so it runs faster?

The filtered data is part of a worksheet with over 10 000 lines, and each week this increases by approximately 1500 lines. (Each year a new file is created, but at the end of the year it's a rather long sheet.)

Sub FilterRows()

  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .Calculation = xlManual
  End With
  
  Dim NewBook As Workbook
  Dim Rng As Range
  
  Dim myDate As Date: myDate = Application.Max(Columns(1))
  
  Dim DataStock As Worksheet
  Set DataStock = ThisWorkbook.Sheets("Data Stock")
   
  With DataStock.Range("A1")
  
    'Check last row
    Dim lastRow As Long
   
    ActiveSheet.AutoFilterMode = False
  
    .AutoFilter Field:=1, Criteria1:="=" & Format(myDate, "dd/mm/yyyy")
    Selection.AutoFilter Field:=3, Criteria1:="<>DSS GNT", Operator:=xlAnd, Criteria2:="<>DSS BUGGENHOUT"
          
    .AutoFilter Field:=13, Criteria1:="1"
    
    .AutoFilter Field:=14, Criteria1:=Array("SNE", "BUG", "GEN", "EUR", "HAM", "MKG", "RHE", "RTZ", "STO"), Operator:=xlFilterValues
    
    .AutoFilter Field:=20, Criteria1:="Y"
    
    lastRow = DataStock.Cells(Rows.Count, 1).End(xlUp).Row
    
    Set NewBook = Workbooks.Add
    Set Rng = ThisWorkbook.Worksheets("Data Stock").Cells.SpecialCells(xlCellTypeVisible)
    Rng.Copy NewBook.Worksheets("Sheet1").Range("A1")
  
  End With
          
  With Application
    .CutCopyMode    = False
    .ScreenUpdating = True
    .DisplayAlerts  = True
    .Calculation    = xlAutomatic
  End With
  
End Sub

You did not answer any of my above clarification questions and not answering related to my suggestions, which is not so convenient when expected for help...

Anyhow, please try the next way which should be must faster. It assumes that the headers are on the first row of the sheet to be processed:

Sub FilterRows()
    Dim NewBook As Workbook, DataStock As Worksheet, rng As Range
    Dim colsNo As Long, iRows As Long, arr

    Set DataStock = ThisWorkbook.Sheets("Data Stock")
    Dim myDate As Date: myDate = Application.Max(DataStock.Columns(1))
    
    DataStock.AutoFilterMode = False
    Set rng = DataStock.UsedRange 'the range to be filtered
    colsNo = rng.Columns.count    'it returns the number of columns to be places in the final array
    
    Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False 'some optimization
    With rng 'I assumed that the headers are on the first row...

      .AutoFilter field:=1, Criteria1:="=" & myDate
      .AutoFilter field:=3, Criteria1:="<>DSS GNT", Operator:=xlAnd, Criteria2:="<>DSS BUGGENHOUT"
          
      .AutoFilter field:=13, Criteria1:="1"
    
      .AutoFilter field:=14, Criteria1:=Array("SNE", "BUG", "GEN", "EUR", "HAM", "MKG", "RHE", "RTZ", "STO"), _
                    Operator:=xlFilterValues
    
      .AutoFilter field:=20, Criteria1:="Y"
      
      iRows = rng.Columns(1).SpecialCells(xlCellTypeVisible).cells.count ' determining the filtered array number of rows
      Set rng = .SpecialCells(xlCellTypeVisible)                         'extracting visible cells of the filtered range
    End With
    Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
    
    'Place the discontinuous range in a 2D continuous array:
    arr = Extract2DArray(rng, iRows, colsNo) ' adding the fourth parameters as `True it will skip headers row

    Set NewBook = Workbooks.Add(xlWBATWorksheet) 'add a single-sheet workbook
    
    'drop the array content in the first sheet of the newly added workbook, at once:
    NewBook.Worksheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr

    MsgBox "Job Done..."
End Sub

'no headers Optional variable allows returning with headers or without. Using the fours argument as True, headers are skipped
Function Extract2DArray(rg As Range, rNo As Long, cNo As Long, Optional noHeaders As Boolean = False) As Variant
  Dim arrRet, j As Long, iRow As Range, k As Long, A As Range
  
  ReDim arrRet(1 To rNo - IIf(noHeaders, 1, 0), 1 To cNo) 'ReDim the necessary array
   For Each A In rg.Areas     'iterate between all range areas
     For Each iRow In A.rows  'iterate between all area rows
        If noHeaders And k = 0 Then GoTo SkipHeadersRow 'skip the first row, if no headers wanted
        k = k + 1
        For j = 1 To cNo
           arrRet(k, j) = iRow.cells(1, j) 'fill the array fow by columns
        Next j
SkipHeadersRow: noHeaders = False
     Next iRow
   Next A
   Extract2DArray = arrRet
End Function

Your code had some bad issues. Firstly, it created a filter for all existing columns in a sheet (16384) consuming Excel resources for filtering itself and for tranformming a discontinuous range in a continuous one to be pasted. Then, it used a set Worksheet, against the active one. If the active sheet was not the set one, it will raise errors or wrong filtering. A selection to be filtered also appeared, without selecting anything and so on.

Please, test the above suggested solution and send some feedback.