Comment accélérer cette petite macro

Public Sub Lecture()

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim Chemin As String
    Dim Facteur As Double
    Dim Compteur As Integer
    Dim objFSO As Variant, objDossier As Variant, objFichier As Variant

    Chemin = "C:\Document"

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objDossier = objFSO.GetFolder(Chemin)

    Compteur = 0
    For Each objFichier In objDossier.Files
        'Postulat :
        '60 minute = 300 MG
        ' x Minute = 700 MG
        'x = ( 700 * 60 ) / 300
        ActiveCell.Offset(Compteur, 0).Value = (objFichier.Size * 60) / 300
        Compteur = (Compteur + 1)
    Next

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Regsvr32.exe c:\Windows\System32\abcavi.dll

Regsvr32.exe c:\Windows\SysWow64\abcavi.dll

Application.screenupdating=False

' Ajouter une référence à "abcAVI Info Library"
' (barre des menus/Outils/Références...)
Option Explicit
Public Sub Listing_Affiche_la_Durée()
' Liste la durée des films
'
Const chemin$ = "F:\Films\Action"          'Adapter le répertoire
Const nbmax% = 5000                        'Adapter nbre max de films
Dim tag As New abcAVI.ExtendedAVITags
Dim AviInfos As Variant
Dim lgr(1 To nbmax) As Variant
Dim fichier As String
Dim début As Single
Dim temps As Single
Dim ctr As Integer
Dim cte As Integer

  début = Timer
  Application.EnableEvents = False
  Range("C1:C" & nbmax).ClearContents
  Range("E1:C" & nbmax).ClearContents
  Application.ScreenUpdating = False
  fichier = Dir(chemin & "\*.avi")
  ctr = 1
  Do While Len(fichier) > 0
    Cells(ctr, 3).Value = fichier
    tag.ReadAVITags chemin & "\" & fichier, PM_Lite_Mode + _
                    PM_Tech_Info, 0, AviInfos
    On Error Resume Next
    lgr(ctr) = tag.GetInfo(AviInfos, IDI_Video_Stream, IDV_Duration)
    lgr(ctr) = lgr(ctr) / (24# * 3600# * 1000#)
    If Err.Number > 0 Then
      lgr(ctr) = ""
      cte = cte + 1
      Range("E1").Offset(cte).Value = cte & ") Film n° " & ctr
    End If
    On Error GoTo 0
    ctr = ctr + 1
    fichier = Dir
  Loop
  Range("C1").Resize(ctr).Value = Application.Transpose(lgr)
  Range("C1").Resize(ctr).NumberFormat = "hh:mm:ss"
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  temps = Timer - début
  If cte > 0 Then Range("E1").Value = "Manque durée de : "
  MsgBox "Terminé en " & Int(temps / 60) & " min. " & _
         Int(temps Mod 60) & " sec. " & _
         Int(temps * 1000 Mod 1000) & " milièmes"
End Sub