Excal 2010 - Faciliter l'exécution d'une macro

Bonjour à tous,

J'ai une macro qui serre à extraire des informations d'une feuille excel pour le coller dans une autre feuille. La macro met 10 -15 seconds à s'exécuter (pas embêtant en soi) mais elle fige aussi le classeur excel (le message '... ne reponds pas...' apparaît dans la barre de titre.

A-t-il quelque chose que je puisse modifier pour éviter ce problème?

Merci d'avance



Mon code:

Sub Accidents1()

With Excel.Application
        .ScreenUpdating = False
        .Calculation = Excel.xlCalculationManual
        .EnableEvents = False
End With


On Error Resume Next
   
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
Dim count As Long
count = 1
count1 = 1
count2 = 1
count3 = 1

With Sheets("WR - Action Plan")


    Set rng = .Range("C:C")


    For Each cell In rng
        If cell.Value = Sheets("WR - Accident Register").Range("N4").Value And cell.Offset(0, 3).Value = "Accident" Then
            
            Range(cell.Offset(0, 8), cell.Offset(0, 10)).Copy

         
            Sheets("WR - Accident Register").Activate
            Range("G22", "I22").End(xlUp).Offset(count, 0).PasteSpecial
            

            Sheets("WR - Action Plan").Activate
            
            
            
            
            
            Range(cell.Offset(0, -1), cell.Offset(0, 1)).Copy

        
            Sheets("WR - Accident Register").Activate
            Range("B22", "D22").End(xlUp).Offset(count1, 0).PasteSpecial
           
            Sheets("WR - Action Plan").Activate
                        


            Range(cell.Offset(0, 4), cell.Offset(0, 5)).Copy

        
            Sheets("WR - Accident Register").Activate
            Range("E22", "F22").End(xlUp).Offset(count2, 0).PasteSpecial
            

            Sheets("WR - Action Plan").Activate
            
            
            
            Range(cell.Offset(0, 19), cell.Offset(0, 19)).Copy

         
            Sheets("WR - Accident Register").Activate
            Range("Q22", "R22").End(xlUp).Offset(count3, 0).PasteSpecial
            
           
            Sheets("WR - Action Plan").Activate
            
            
        End If
    Next
End With

With Excel.Application
        .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
End With


End Sub