Optimisation code VBA pour accélérer le processus [Fermé]

Signaler
Messages postés
22
Date d'inscription
mercredi 5 mars 2014
Statut
Membre
Dernière intervention
19 juillet 2016
-
Messages postés
23596
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
26 octobre 2020
-
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

2 réponses

Bonjour,
avez-vous pensé à mettre en début de macro (apres sub () )
Application.ScreenUpdating = False

et en fin de macro (avant end Sub)
Application.ScreenUpdating = true

Ca peut faire gagner énormément de temps sur l'exécution d'une macro.
Messages postés
22
Date d'inscription
mercredi 5 mars 2014
Statut
Membre
Dernière intervention
19 juillet 2016

Bonjour,
J'ai mis:
Set xl = New Excel.Application
xl.Visible = False

La macro tourne via Access, je n'ouvre pas directement de fichier excel.
Je vais ajouter ce que vous proposer également.
Messages postés
22
Date d'inscription
mercredi 5 mars 2014
Statut
Membre
Dernière intervention
19 juillet 2016

En fait la commande Application.ScreenUpdating = False ne fonctionne dans Access...

D'autres suggestions ?
>
Messages postés
22
Date d'inscription
mercredi 5 mars 2014
Statut
Membre
Dernière intervention
19 juillet 2016

Oups désolé je ne savais pas que cette commande ne fonctionnait pas sous accès...
Il faudra attendre la réponse d'un expert alors.
Bonne soirée,
Messages postés
23596
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
26 octobre 2020
6 424
Bonjour,

lire cellule par cellule est très chronophage.
Il faut lire toutes les données en une fois dans une variable tableau, et inversement pour écrire.
Ex succinct :
Dim datas ' Variant
'lire
datas = Range("A1:E10")
'modifier
datas(5, 3) = 150 'ligne,colonne)
'écrire
Range("A1:E10") = datas = Range("A1:E10")

Ca ira 100 fois plus vite.
Par contre pour relever la couleur pas d'autre possibilité que de lire les cellules.
eric


En essayant continuellement, on finit par réussir. 
Donc plus ça rate, plus on a de chances que ça marche.(les Shadoks)
En plus du merci (si si, ça se fait !!!), penser à mettre en résolu. Merci
Messages postés
22
Date d'inscription
mercredi 5 mars 2014
Statut
Membre
Dernière intervention
19 juillet 2016

Merci Eriiic, j'ai testé avec la macro ci-dessous. ça fonctionne, mais ça n'accélère pas tant que ça (encore 45 sec, sans compter la copie des couleurs qui n'a plus lieu).
Est-ce que l'on peut faire un tableau des worksheet (car la macro boucle sur toutes les worksheets du fichiers, actuellement 3 mais jusqu'à 9 possible).

Merci pour ton aide.
Diane

Dim compt1 As Long, compt2 As Long
Dim PlageV As Variant

For Each Freezer In ActiveWorkbook.Worksheets '>>>>>>>> puis-je faire des worksheet un tableau également ??
PlageV = Freezer.Range("C5:L63").Value

'Boucle
For compt1 = LBound(PlageV, 1) To UBound(PlageV, 1)
For compt2 = LBound(PlageV, 2) To UBound(PlageV, 2)
If PlageV(compt1, compt2) <> Empty Then
If PlageV(compt1, compt2) <> "Rack ID" Then
'Copie les valeurs du freezer interface
Workbooks(strFilename).Worksheets(1).Range("B" & LinB).Value = PlageV(compt1, compt2)
'copie le nom du freezer
Workbooks(strFilename).Worksheets(1).Range("A" & LinB).Value = Freezer.Name

LinB = LinB + 1
Else
End If
End If
Next compt2
Next compt1
Next

End With
Messages postés
23596
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
26 octobre 2020
6 424
Bonjour,

ben oui, tu as traité la lecture mais tu continues à écrire cellule par cellule.
Il faut écrire dans un tableau. Le même si c'est pour remplacer certaines données ou un que tu déclares.
Comme apparement il ne sera pas trop long tu le dimensionnes à la taille maxi que tu risques d'avoir besoin.
Et ensuite l'inscrire en une fois : ta_plage = ton_tableau
Tu es obligé de faire feuille par feuille.
eric