VBA Slow code, please help optimize

[pipe]

Intro :
First post here or any forum actually. Hope someone can help me optimize my code. I'm definitly not a programer. The company I work for don't have more ressources to do better automation of this kind of manuel procedures, but apparently I am better then keeping the manual method. I did my best, mostly by scrapping the code of others, and I don't know how to make this faster or, unpretentiously, if it can be optimized.

Problem :
My macro does few steps of filtering and deleting data and I find it slow for the actual amount of data it treats. It's about 90k rows at the beginning and 5K to 10K once done. Does anyone have pro-tips or obvious reasons why it's so long (30 to 40 minutes).

Context :
I splited the macro falsly thinking it would be faster ... My question is only for the second part. The first part loop through directories creating a collection through which I loop to open a daily file always named SHORTTRD.RPT. I condense them to do a monthly file. I use this monthly file to do those multiples manipulations to transforme the data. This file is quite confidential so I can't share it ... Here's my code. Excuse my english and if some of my notes are in french.

Since there's a lot of .Autofilter, .Range.EntireRow.Delete and .ShowAllData I mainly focused on trying variants of -> .EntireRow.Delete to optimize the number of rows to delete.
I tried :

Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row).EntireRow.Delete ;
Range("A2:A" & .Cells(Rows.Count, 1).End(xlDown).Row).EntireRow.Delete ;
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete ;
Columns("A:A").SpecialCells(xlCellTypeVisible).EntireRow.Delete ;
[ LastRow = .Cells.Find(What:="*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("A2:A" & LastRow).EntireRow.Delete

Option Explicit

'*****************************************************************************************
'* Ajouter la référence «Microsoft Scripting Runtime»
'*****************************************************************************************

Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long

Public Function ChDirNet(ByVal szPath As String) As Integer

    Dim lReturn As Long
    lReturn = SetCurrentDirectoryA(szPath)
    ChDirNet = lReturn
   
End Function

Sub Trier_Filtrer()

Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim RepFichier As String
RepFichier = "Valid directory"

ChDirNet (RepFichier)

Dim ExportData As Workbook
Workbooks.Open Filename:="ExportData.xlsx"

Dim dic As Object
Dim eleData As Variant
Dim eleCrit As Variant
Dim arrData As Variant
Dim arrFlt As Variant
Dim LastRow&

'************************************************
'[URL='https://www.mrexcel.com/board/threads/wild-card-unable-to-use-in-autofilter-array.917998/']Wild card unable to use in autofilter array[/URL]
'Construction d'un array pour Autofilter Cirteria1, pcq l'usage du Wildcard "*" dans un array trop gros n'est pas possible
Set dic = CreateObject("Scripting.Dictionary")
arrFlt = Array("Report: INASHORTT", "**", "Account", "Broker:", "*-*")

With ActiveSheet

    .AutoFilterMode = False
'[URL='https://www.mrexcel.com/board/threads/clearcontents-really-slow-anything-faster.348744/']ClearContents really slow... anything faster?[/URL]
     LastRow = .Cells.Find(What:="*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'arrData = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
    arrData = .Range("A1:A" & LastRow)
    For Each eleCrit In arrFlt
        For Each eleData In arrData
            If eleData Like eleCrit Then dic(eleData) = vbNullString
        Next
    Next
'************************************************
   
'Delete les dates par rapport A:A, moins compliqué de passer par O:O
'Not able to filter A for this form of date 2020-03-01  2:43:00 AM thoroughly whenever we will be in the future, so use O:O
    .Columns("A:O").AutoFilter Field:=15, Criteria1:="PAGE :      1"
    .Range("O2:O" & LastRow).EntireRow.Delete

'Delete les critères dans arrFlt
    .ShowAllData
    .Columns("A:A").AutoFilter Field:=1, Criteria1:=dic.Keys, Operator:=xlFilterValues
    .Range("A2:A" & LastRow).EntireRow.Delete

'Delete les cells vides
    .Columns("A:A").AutoFilter Field:=1, Criteria1:="="
    .Range("A2:A" & LastRow).EntireRow.Delete
    .ShowAllData

'Delete D:D, G:G
    .Columns("D:D").EntireColumn.Delete
    .Columns("F:F").EntireColumn.Delete
   
'Brokers et numéros de contrats
    .Columns("A:A").Insert Shift:=xlToRight
    Columns("A:A").Value = .Columns("B:B").Value
    .AutoFilterMode = False
  'Enlever tous Brokers de B:B
    .Columns("A:N").AutoFilter Field:=2, Criteria1:="*Broker*"
    .Range("B2:B" & LastRow).Clear
  'Enlever tous les contrats de A:A
    .ShowAllData
    .Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Broker*"
    .Range("A2:A" & LastRow).Clear
  'Descendre tous les brokers d'une ligne
    .ShowAllData
    Range("A2").Insert Shift:=xlDown
  'Enlever les cellules vides
    .Columns("B:B").AutoFilter Field:=2, Criteria1:="="
    .Range("B2:B" & LastRow).EntireRow.Delete
  'drag les Brokers sur tous les lignes
  'Used macro recorder
    .ShowAllData
    LastRow = .Cells.Find(What:="*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    .Range("A2:A" & LastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Range("A2:A" & LastRow).Copy
    .Range("A2").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
   
'Enlever les fonds 2070 et 020
    .Columns("C:C").AutoFilter Field:=3, Criteria1:=Array("=020", "=2070")
    .Range("C2:C" & LastRow).EntireRow.Delete
   
'Enlever les Trans. Type <> EO
    .ShowAllData
    .Columns("G:G").AutoFilter Field:=7, Criteria1:="<>EO"
    .Range("G2:G" & LastRow).EntireRow.Delete

'Enlever Âge > 30j
    .ShowAllData
    LastRow = .Cells.Find(What:="*", After:=.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    .Columns("K:K").AutoFilter Field:=11, Criteria1:=">30"
    .Range("K2:K" & LastRow).EntireRow.Delete

'Import heading
    .Range("A1:N1").Value = ThisWorkbook.Worksheets("Format").Range("A1:N1").Value
    .ShowAllData

'Ajout colonne "même série ?" et "même fonds ?"
    .Range("O1").FormulaR1C1 = "Même série ?"
    .Range("O2").FormulaR1C1 = "=EXACT(RC[-11],RC[-9])"
    .Range("P1").FormulaR1C1 = "Même fonds ?"
    .Range("P2").FormulaR1C1 = "=EXACT(RC[-13],RC[-11])"
    .Range("O2:P2").AutoFill Destination:=Range("O2:P" & LastRow), Type:=xlFillDefault

'Ajuster largeur colonne
    .Columns("A:P").EntireColumn.AutoFit
   
'Enlever lignes même série = FALSE et même fonds = TRUE
    .AutoFilterMode = False
    .Columns("A:P").AutoFilter Field:=15, Criteria1:="=FALSE"
    .Columns("A:P").AutoFilter Field:=16, Criteria1:="=TRUE"
    .Range("O2:O" & LastRow).EntireRow.Delete

'Trier par contrat
    .ShowAllData
    .AutoFilterMode = False
    .Range("A1").CurrentRegion.Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlYes

End With

ActiveCell.CurrentRegion.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True


Workbooks("ExportData.xlsx").Save
Workbooks("ExportData.xlsx").Close

Set dic = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
Debug.Print "This code ran successfully in " & MinutesElapsed & " minutes"

End Sub

 

[NdNoviceHlp]

Hi pipe and Welcome to the Board! I'm fairly certain that the filter thing is fairly slow but I'm not real sure what your objective is when your using it? Anyways, using Find is also very slow, so U can replace your "Lastrow" code with the following (adjust the sheet name and column as needed). HTH. Dave

With Sheets("Sheet1")
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With