Optimisation code VBA pour accélérer le processus

Bonjour,

J'ai un code vba dans une base access, qui compare des data d'un fichier excel et de la database, les tries et export le tout dans un fichier excel puis pdf.
J'ai fait plusieurs macros ("Sub") et l'un d'entre elle dure plus d'1 min et un autre 9 min !! Je cherche à optimiser le code afin de réduire ce temps de process.

Pourriez-vous m'aider ?

Ci-dessous quelques infos. Merci d'avance.
Diane

Le bout de code est ci-dessous pour la macro d'1 min: cette macro consiste à chercher les valeurs dans une plage de données de tous les onglets d'un fichier excel (jusqu'à 9 onglets - 2430 valeurs) et les coller dans une colonne dans un autre fichier ("strFilename").

    For Each Freezer In ActiveWorkbook.Worksheets
        Set Plage = Freezer.Range("C5:L63")
        'Boucle
        For Each Cell In Plage
            If Cell.Value <> Empty Then
                If Cell.Value <> "Rack ID" Then
                    'Copie les valeurs du freezer interface
                    Workbooks(strFilename).Worksheets(1).Range("B" & LinB).Value = Cell.Value
                    'copie les couleurs
                    Workbooks(strFilename).Worksheets(1).Range("B" & LinB).Interior.Color = Cell.Interior.Color
                    'copie le nom du freezer
                    Workbooks(strFilename).Worksheets(1).Range("A" & LinB).Value = Freezer.Name
                    
                    LinB = LinB + 1
                Else
                End If
            End If
        Next
    Next
    End With

Le second bout de code ci-dessous (9 min) consiste à comparer et supprimer parmi les 2430 valeurs collées précédemment à celles initialement dans le fichier strFilename (64 valeurs max).

derlig = Workbooks(strFilename).Worksheets(1).Range("B" & Rows.Count).End(xlUp).Row
    
    For i = 2 To derlig
        FindString = Workbooks(strFilename).Worksheets(1).Range("B" & i).Value
        If Trim(FindString) <> "" Then
            With Sheets(1).Range("E2:E65")
                Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                If Rng Is Nothing Then
                    Sheets(1).Range("A" & i).Delete Shift:=xlUp
                    Sheets(1).Range("B" & i).Delete Shift:=xlUp
                   
                    i = i - 1
                Else
                    Sheets(1).Range("C" & Rng.Row).Copy
                    Sheets(1).Range("F" & i).PasteSpecial xlPasteAll
                    Sheets(1).Range("D" & Rng.Row).Copy
                    Sheets(1).Range("G" & i).PasteSpecial xlPasteAll

                End If
            End With
        End If
    Next
    
    'MsgBox "Next" 9 min 25 sec processing time
   
End Sub