Optimisation de code VBA - lenteur macro

Sub RechTABCAts()

Sheets("INTEG").Select

Dim Nbdedonnees As Long
Nbdedonnees = Application.WorksheetFunction.CountA(Range("N:N"))

Dim NbElements As Long
NbElements = Application.WorksheetFunction.CountA(Range("B:B")) - Nbdedonnees

Dim NbTabCAts2 As Long
NbTabCAts2 = Application.WorksheetFunction.CountA(Sheets("TAB CAts2").Range("A:A"))

Dim NbTabCAts As Long
NbTabCAts = Application.WorksheetFunction.CountA(Sheets("TAB CAts").Range("A:A"))

Dim NbNDTABCAts As Long
NbNDTABCAts = 0

Dim CompteurValCAts As Integer
CompteurValCAts = 0

Dim RechCAts(1 To NbElements, 6)
For x = 1 To NbElements

RechCAts(x, 1) = Left(Cells(Nbdedonnees + x, 4), 6) 'Récupération des 6 premiers caractères du code comptable

' Recherche dans TAB CAts2 par rapport au 6 premiers caractères
    For g = 1 To NbTabCAts2
        If RechCAts(x, 1) = Sheets("TAB CAts2").Cells(g, 1).Value Then 'si correspondance avec la table trouvée, récupérer les données
                RechCAts(x, 2) = Sheets("TAB CAts2").Cells(g, 4).Value
                RechCAts(x, 3) = Sheets("TAB CAts2").Cells(g, 5).Value
                RechCAts(x, 4) = Sheets("TAB CAts2").Cells(g, 6).Value
                RechCAts(x, 5) = Sheets("TAB CAts2").Cells(g, 7).Value
                RechCAts(x, 6) = Sheets("TAB CAts2").Cells(g, 8).Value
                CompteurValCAts = CompteurValCAts + 1
                g = NbTabCAts2 + 1 'si valeur trouvée, sortir de la boucle
        End If
    Next g
    
   'Sinon, rechercher les donner dans la table TAB CAts
        If CompteurValCAts = 0 Then
            For f = 1 To NbTabCAts
                If Cells(Nbdedonnees + x, 4).Value = Sheets("TAB CAts").Cells(f, 1).Value Then
                    RechCAts(x, 2) = Sheets("TAB CAts").Cells(f, 2).Value
                    RechCAts(x, 3) = Sheets("TAB CAts").Cells(f, 3).Value
                    RechCAts(x, 4) = Sheets("TAB CAts").Cells(f, 4).Value
                    RechCAts(x, 5) = Sheets("TAB CAts").Cells(f, 5).Value
                    RechCAts(x, 6) = Sheets("TAB CAts").Cells(f, 6).Value
                    CompteurValCAts = CompteurValCAts + 1
                    g = NbTabCAts2 + 1 'si valeur trouvée, passer à la ligne suivante
                End If
            Next f
        End If
        
        If CompteurValCAts = 0 Then ' SInon indiquer qu'il n'y a pas de correspondance et renvoyer le nombre de lignes sans correspondance dans une msgbox
            RechCAts(x, 2) = "ND TAB CAts"
            RechCAts(x, 3) = "ND TAB CAts"
            RechCAts(x, 4) = "ND TAB CAts"
            RechCAts(x, 5) = "ND TAB CAts"
            RechCAts(x, 6) = "ND TAB CAts"
            NbNDTABCAts = NbNDTABCAts + 1
        End If

Next x

For x = 1 To NbElements 'récupération des données  de RechCAts dans les cellules de la feuille Integ
    Cells(Nbdedonnees + x, 14).Value = RechFrs(x, 2)
    Cells(Nbdedonnees + x, 15).Value = RechFrs(x, 3)
    Cells(Nbdedonnees + x, 16).Value = RechFrs(x, 4)
    Cells(Nbdedonnees + x, 17).Value = RechFrs(x, 5)
    Cells(Nbdedonnees + x, 18).Value = RechFrs(x, 6)
Next x

Erase RechFrs

MsgBox ("Recherches n'ayant pas aboutit : " & NbNDTABCAts)

End Sub

For x = 1 To NbElements 'récupération des données  de RechCAts dans les cellules de la feuille Integ
    Cells(Nbdedonnees + x, 14).Value = RechCAts(x, 2)
    Cells(Nbdedonnees + x, 15).Value = RechCAts(x, 3)
    Cells(Nbdedonnees + x, 16).Value = RechCAts(x, 4)
    Cells(Nbdedonnees + x, 17).Value = RechCAts(x, 5)
    Cells(Nbdedonnees + x, 18).Value = RechCAts(x, 6)
Next x

Erase RechCAts

Option Base 1
'---------------------------------
Sub rechercher()
Dim Derlig As Long, NbElements As Long, T_integ   'sh integ
Dim T_cats 'sh tab cats
Dim T_cast2 'sh tab cats2
Dim Cptr As Long, Lig As Long, Col As Byte, CompteurValCAts As Long

'---------------------Initialisations
    Application.ScreenUpdating = False
    'mémorisation RAm données
    With Sheets("integ")
        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        T_integ = .Range("A2:R" & Derlig)
    End With
   With Sheets("TAB CAts")
        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        T_cats = .Range("A2:E" & Derlig)
    End With
    With Sheets("TAB CAts2")
        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        T_cats2 = .Range("A2:H" & Derlig)
    End With
'------------------------------traitement des données
    For Cptr = 1 To UBound(T_integ)
        'Récupération des 6 premiers caractères du code comptable
        T_cats(Cptr, 1) = Left(T_integ(Cptr, 4), 6)
        For Lig = 1 To UBound(T_cast2)
            'si correspondance avec la table trouvée, récupérer les données
            If T_cats(Cptr, 1) = T_cats2(Lig, 1) Then
               For Col = 2 To 6
                    T_cats(Cptr, Col) = T_cast2(Lig, Col + 2)
                Next Col
                Exit For
            End If
            ''Sinon, rechercher les donner dans la table TAB CAts
            If CompteurValCAts = 0 Then
            '......... à toi de jouer
       Next For
    Next Lig
    '........
End Sub

Option Explicit
Option Base 1
'---------------------------------
'le but de ce code est de faire les recherches sur une première table, _
puis sur une seconde en cas d'échec, _
puis de renvoyer un message en cas d'absence de correspondance dans les deux tables

'-----------------------------------------------------------------------------------------------
Sub rechercher()
Dim Derlig As Long, Ligvid As Long, T_integ, T_calcul  'sh integ
Dim T_cats, D_cats As Object 'sh tab cats
Dim T_cast2, D_cast2 As Object 'sh tab cats2
Dim Cptr As Long, Coda As String, Lig As Long, Col As Byte 'traitement
Dim NbNDTABCAts As Long 'traitement
Dim Start As Single 'test durée d'execution

'-------------------------------initialisation
    Start = Timer
    Application.ScreenUpdating = False
    'mémorisation RAm données
    With Sheets("integ")
        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        Ligvid = .Columns("N").Find(what:="", after:=.Range("N1")).Row
        T_integ = .Range(.Cells(Ligvid, "A"), .Cells(Derlig, "U"))
        ReDim T_calcul(Derlig - Ligvid+1, 5)
    End With
   With Sheets("TAB CAts")
        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        T_cats = .Range("A2:E" & Derlig)
        'liste des coda et ligne de position(cptr)
        Set D_cats = CreateObject("scripting.dictionary")
        For Cptr = 1 To UBound(T_cats)
            If Not D_cats.exists(T_cats(Cptr, 1)) Then: D_cats.Add T_cats(Cptr, 1), Cptr
        Next
    End With
    With Sheets("TAB CAts2")
        Derlig = .Columns("A").Find(what:="*", searchdirection:=xlPrevious).Row
        T_cast2 = .Range("A2:H" & Derlig)
        Set D_cast2 = CreateObject("scripting.dictionary")
        For Cptr = 1 To UBound(T_cast2)
            If Not D_cast2.exists(T_cast2(Cptr, 1)) Then: D_cast2.Add T_cast2(Cptr, 1), Cptr
        Next
    End With
'------------------------------traitement des données
    For Cptr = 1 To UBound(T_integ)
        Coda = Left(T_integ(Cptr, 4), 6)
        If D_cast2.exists(Coda) Then
            Lig = D_cast2.Item(Coda)
            For Col = 4 To 8
                    T_calcul(Cptr, Col - 3) = T_cast2(Lig, Col)
            Next Col
        Else
            Coda = T_integ(Cptr, 4)
            If D_cats.exists(Coda) Then
                Lig = D_cats.Item(Coda)
                For Col = 2 To 6
                    T_calcul(Cptr, Col - 1) = T_cats(Lig, Col)
                Next Col
            Else
                For Col = 1 To 4
                    T_calcul(Cptr, Col) = "ND TAB CATS"
                Next Col
                NbNDTABCAts = NbNDTABCAts + 1
            End If
        End If
    Next
    '---------------------------------restitution
    With Sheets("integ")
        .Range("N" & Ligvid).Resize(UBound(T_calcul), 4) = T_calcul
    End With
    Application.ScreenUpdating = True
    MsgBox ("Recherches n'ayant pas abouti : " & NbNDTABCAts & vbLf & _
                        "durée de traitement: " & Timer - Start & " secondes")
End Sub