accélerer macro

[superbog]

Bonjour,

J'ai une macro qui est très lente, pourriez vous m'aider à la rendre plus rapide?

La voici

Sub BB()

 Dim i, DerLigBase, lig2, lig As Integer
 Dim dossier, sNomFeuille As String
 Dim colFeuille As Collection
 Dim rCelA As Range
 Dim shAct As Worksheet
 Dim FeuilleExist As Boolean

 'Recherche de la dernière ligne
 DerLigBase = Sheets("BB").Range("B9000").End(xlUp).Row
 Set colFeuille = New Collection
 On Error Resume Next
 'Boucle sur la plage de cellule

 For Each rCelA In Sheets("BB").Range("B2:B" & DerLigBase)
     colFeuille.Add rCelA, CStr(rCelA)
 Next rCelA

 'Recherche de la ligne et tri dans chaque feuille
 For i = 2 To DerLigBase
     dossier = Cells(i, 2).Text
     lig = Sheets(dossier).Range("B9000").End(xlUp).Row
         lig2 = Sheets(dossier).Range("V1000").End(xlUp).Row

      'Copie les valeurs tp si non cochées
     With Sheets("BB").Cells(i, "C").Resize(, 10)
             If IsEmpty(Sheets("BB").Cells(i, 1)) And IsNumeric(Sheets("BB").Cells(i, 2)) Then
              'colonne A vide
                 Err = 0 'pour savoir si une erreur se produit
                    Worksheets(dossier).Cells(lig + 1, "B").Resize(, 6) = .Value
                    Worksheets(dossier).Cells(lig2 + 1, "V").Resize(, 2) = .Value
                    Worksheets(dossier).Cells(lig + 1, "H") = "BB"
                   If Err = 0 Then .Cells(-1) = "X"
                   End If
              'Copie les valeurs devis
                  With Sheets("BB").Cells(i, "I").Resize(, 3)
                        Worksheets(dossier).Cells(lig2 + 1, "X").Resize(, 3) = .Value
                  End With
                    
                    With Sheets("BB").Cells(i, "L").Resize(, 1)
             Worksheets(dossier).Cells("G3") = .Value
             End With
             
      End With
      
 Next i

 End Sub

merci d'avance

 

[superbog]

Re : accélerer macro

voici un fichier test

merci d'avance