Accélération code vba

Bonjour à tous,

Ci-joint un fichier sur lequel j'ai travaillé avec l'aide d'un membre du forum.
http://www.cjoint.com/c/EFspZVpxePv

Le code ci-dessous (en module 5) est très lent (j'ai plus de 6000 lignes à traiter)

Si certains d'entre vous ont une idée pour accélérer ce code je suis preneur.

J'ai lu sur un autre forum :

"le truc, c'est de passer par un tableau. Tu définis toute la zone sur laquelle tu va travailler et tu la mets dans un Range. Tu définis ensuite un Variant et tu mets le Range dedans. Tu travailles sur le Variant, il n'y a plus d'accès à la feuille et ça va 10 fois plus vite. A la fin tu remets le Variant dans le Range d'un seul coup."

Exemple

Dim rg As Range
Dim v as Variant
Set rg = Worksheets("MaFeuille").Range("A1:G10000")
v = rg
'On travaille sur v ...
rg = v

Vous pensez que je peux utiliser cette méthode dans mon code? Je ne la comprends pas trop.

Mon code que j'essaie d'améliorer :

Merci d'avance pour vos conseils.

Sub Actu()
Dim DLig As Long
Dim i As Long
Dim f As Long
Dim ID As Long
Dim Trouve As Object, PlageDeRecherche As Range

Dim sngChrono As Single

sngChrono = Timer

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Set PlageDeRecherche = Sheets("Feuil1").Columns(1)
For f = 2 To Worksheets.Count
  With Sheets(f)
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    DCol = .Cells(10, Columns.Count).End(xlToLeft).Column
    For i = 11 To DLig
      ID = .Range("A" & i).Value
      Set Trouve = PlageDeRecherche.Find(what:=ID, LookAt:=xlWhole)
      If Not Trouve Is Nothing Then
        therow = Trouve.Row
        .Range(.Cells(i, 17), .Cells(i, DCol)).Copy Destination:=Sheets("Feuil1").Range("Q" & therow)
      Else
      MsgBox ID & " ID Number Not found"
      End If
    Next i
  End With
Next f

Application.ScreenUpdating = True

sngChrono = Timer - sngChrono
MsgBox "Temps d'execution du code en sec : " & CStr(sngChrono)

End Sub