Accélérer l'exécution d'un code VBA

Bonjour à tous,

C'est mon premier post ici, malgré que je visite régulièrement les sujets et que je trouve souvent mon bonheur, mais là je ne saurais pas comment faire :

Je vous explique, il y a une feuille normale (pas userform) appelée "interface" dans laquelle les utilisateurs remplissent des champs, en suite ils doivent cliquer sur valider et cela ajoute ces données à une BDD (base de données). Le code marche mais il est TROOOP lent.

J'ai donc mis un bouton avec les instructions pour que cela se fasse, le remplissage n'est pas "simple' en effet il est "en cascade" ainsi en français ça donne ça :

Si au moins une case de la plage1 est remplie alors associe à chaque case remplie, les valeurs de la plage2

Si au moins une case de la plage2 est remplie alors copie dans la base de données

Bref, ainsi si dans la plage1 il y a : Test1 test2

et dans la plage2 il y a : p1 p2 et p3 donc dans la base de données cela se copie ainsi par colonne :

Bref voici l'interface et le code :

Private Sub ValiderBDD_Click()
'____AMELIORATION ajoutée soi disant pour la rendre plus rapide :( 
Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer

BoEcran = Application.ScreenUpdating
BoBarre = Application.DisplayStatusBar
iCalcul = Application.Calculation
BoEvent = Application.EnableEvents
BoSaut = ActiveSheet.DisplayPageBreaks

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'---------------------------------------------

'Copie cases dans la BDD

Dim Col As Integer

Dim ligne As Integer
'debut d'jout
Set plage = Range("B15:F19")
Set semaine = Range("C11")
Set annee = Range("E11")
Set ope = Range("C12")
Set typ = Range("C2")

'TEST SI PLAGE VIDE
If Application.CountA(plage) = 0 Or Application.CountA(semaine) = 0 Or Application.CountA(annee) = 0 Or Application.CountA(ope) = 0 Or Application.CountA(typ) = 0 Then
MsgBox ("Veuillez renseigner au moins une OF, date, année, opérateur et semaine")
Else: 

'Teste OF NON VIDES
 For Each C In Worksheets("Interface").Range("B15:F19").Cells

 If Not IsEmpty(C.Value) Then 'Si Numéro d'OF non vide alors
    For Each D In Worksheets("Interface").Range("C23:E23").Cells 'pour chaque Peinture faire :

    If Not IsEmpty(D.Value) Then 'Si cellule peinture non vide alors

        For Col = 1 To 9 'colonnes de 1 à 9 dans BDD
            ligne = comptage(2, Col)
            If Col = 1 Then
            'Colonne Année
            Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Range("E11").Value
            'Colonne Semaine
            ElseIf Col = 2 Then
            Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Range("C11").Value
            'Peinture donnée
            ElseIf Col = 3 Then
            Worksheets("BDD").Cells(ligne, Col) = C.Value
            'Conformité Adhérence
            ElseIf Col = 4 Then
            Worksheets("BDD").Cells(ligne, Col) = D.Value 'peinture
            Worksheets("BDD").Cells(ligne, Col + 1) = Worksheets("Interface").Cells(D.Row + 1, D.Column).Value2 'adhe
            Worksheets("BDD").Cells(ligne, Col + 2) = Worksheets("Interface").Cells(D.Row + 2, D.Column).Value2 'épaisseur
            Worksheets("BDD").Cells(ligne, Col + 3) = Worksheets("Interface").Cells(D.Row + 3, D.Column).Value2 'Conformité ép
            Worksheets("BDD").Cells(ligne, Col + 4) = Worksheets("Interface").Cells(D.Row + 4, D.Column).Value2 'Opérateur
            Worksheets("BDD").Cells(ligne, Col + 5) = Worksheets("Interface").Cells(D.Row + 5, D.Column).Value2 'Type (Retouch/Init)
            Worksheets("BDD").Cells(ligne, Col + 6) = Worksheets("Interface").Cells(D.Row + 6, D.Column).Value2 'Programme
            'ElseIf Col = 5 Then
            'Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Cells(D.Row + 1, D.Column).Value2
           'ElseIf Col = 6 Then
            'Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Cells(D.Row + 2, D.Column).Value2
            'ElseIf Col = 7 Then
            'Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Cells(D.Row + 3, D.Column).Value2
            'ElseIf Col = 8 Then
            'Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Cells(D.Row + 4, D.Column).Value2
            'ElseIf Col = 9 Then
            'Worksheets("BDD").Cells(ligne, Col) = Worksheets("Interface").Cells(D.Row + 5, D.Column).Value2
            End If
        Next
    End If
    Next

End If
Next
MsgBox ("Données ajoutés avec succès")
End If 'ajout

'--------AMELIIORATION FIN 
Application.ScreenUpdating = BoEcran
Application.DisplayStatusBar = BoBarre
Application.Calculation = iCalcul
Application.EnableEvents = BoEvent
ActiveSheet.DisplayPageBreaks = BoSaut

End Sub

Merci d'avance pour votre aide

Bonjour

Déjà je vois plein de variables déclarées qui ne sont pas nécessaires. N'oubliez pas que chaque variable inclut une allocation de mémoire qu'Excel doit gérer et qu'excel a besoin de mémoire pour fonctionner.

Sans voir votre fichier je pense que vous pouvez supprimer ceci car vous déclarez plus bas à FALSE, donc cela sert pas

BoEcran = Application.ScreenUpdating
BoBarre = Application.DisplayStatusBar
iCalcul = Application.Calculation
BoEvent = Application.EnableEvents
BoSaut = ActiveSheet.DisplayPageBreaks

Elles ne servent pas dans cette macro.

Pour la fin du code dans les instructions Application, remplacez les variables B0Ecran, bobarre, etc... par la valeur TRUE

Ensuite il faudrait voir votre fichier pour analyser plus car là vous avez 3 boucles imbriquées... cela ralenti à coup sûr

Edit : sur cette ligne, vous avez une fonction ? --> Ligne = comptage(2, col)

Bonjour Cosmo_Vehicle_Corp

Bonjour Dan,

et j'ajoute qu'il faut travailler en array et non avec les plages si tu veux arriver à un rythme fulgurant !

Bonjour,

Au lieu de travailler sur des Cells, il faudrait travailler sur un Array (C'est beaucoup plus rapide !) mais c'est impossible sans avoir le classeur KIVABIEN avec.

EDIT Dan : "Elles ne servent pas dans cette macro."

Si elles servent à mémoriser les valeurs d'origine puis à ramener le classeur à ces valeurs d'origine à la fin !

A+

Merci beaucoup pour vos réponses si rapides :

Voici donc le classeur en question. Pour répondre à Dan, j'avais copié cela bêtement à partir d'une page internet :

Je n'arrive pas à mettre en place la méthode avec Array (méconnaissance) j'avais testé de mettre les données de la première plage dans une variable de type Variant mais cela copiait toutes les valeurs y compris les vides dans la base de données.

Je suis on va dire "autodidacte" d'où ma méconnaissance

Je n'arrive pas à joindre le fichier :(

Si le classeur est trop volumineux (plusieurs Go) il faut supprimer les pages inutiles et dans la BD ne laisser que quelques lignes pour que tout puisse fonctionner.

A+

galopin01 a écrit :

Si le classeur est trop volumineux (plusieurs Go) il faut supprimer les pages inutiles et dans la BD ne laisser que quelques lignes pour que tout puisse fonctionner.

Pour compléter, le fichier doit peser 1.5Mo max.
Au vu du nom de la macro de type PRIVATE et de la ligne Comptage, je pense qu'il doit y avoir d'autres codes dans le fichier.

La ligne comptage c'est juste une fonction pour compter le nombre de lignes j'ai tout supprimé de superflu, mais ça ne marche point.

J'ai décidé de rendre commentés tout le code, et ça ne marche toujours pas, il y a pourtant que le code pour la macro et le bouton en question :(

Le code se trouve là

Enfin, voici le fichier ci-dessous :)

galopin01 a écrit :

EDIT Dan : "Elles ne servent pas dans cette macro."

Si elles servent à mémoriser les valeurs d'origine puis à ramener le classeur à ces valeurs d'origine à la fin !

A+

Tu as vu qu'il met les instructions à FALSE 5 lignes plus bas. Et les variables BOxxx ne servent pas plus loin dans le code. Donc je ne comprends pas l'utilité.

Les variables BOxx je les avais bêtement copiées d'un site internet

mais là sur le dernier fichier je les ai supprimées comme dit par Dan, mais je pense que là n'est pas le problème du ralentissement

sur ce site :

lecfomasque.com /vba-rediger-des-macros-plus-rapides/

Il manque la fonction dans le fichier et les valeurs possibles dans les listes déroulantes

je pense que vous auriez pu laisser une dizaine de lignes dans la BDD que l'on voit comment est le fichier

Voici le fichier en théorie tout se remplit "manuellement' les listes déroulantes sur semaine ou année c'était juste pour que l'user ne mette pas des valeurs aberrantes comme semaine 60 ou année 2000001

Merci d'avance pour votre aide

Re

Essayez avec ce code

Private Sub ValiderBDD_Click()
'Copie cases dans la BDD
Dim i As Byte
Dim ligne As Integer
Dim Annee As Range, Plage As Range, Semaine As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'debut ajout
Set Plage = Range("B15:F19")
Set Semaine = Range("C11")
Set Annee = Range("E11")

'TEST SI PLAGE VIDE
If Application.CountA(Plage) = 0 Or Application.CountA(Semaine) = 0 Or Application.CountA(Annee) = 0 Or Application.CountA(ope) = 0 Or Application.CountA(typ) = 0 Then
MsgBox ("Veuillez renseigner au moins une OF, date, année, opérateur et semaine")
Else:
    For Each C In Worksheets("Interface").Range("B15:F19").Cells

       If Not IsEmpty(C.Value) Then 'Si Numéro d'OF non vide alors

           For i = 3 To 5
               ligne = Sheets("BDD").Range("A" & Sheets("BDD").Rows.Count).End(xlUp).Row + 1
               If Not IsEmpty(Cells(23, i)) Then
                   With Worksheets("BDD")
                       .Range("A" & ligne) = Annee
                       .Range("B" & ligne) = Semaine
                       .Range("C" & ligne) = C.Value
                       Worksheets("Interface").Range(Cells(23, i), Cells(28, i)).Copy
                       .Range("D" & ligne).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

                   End With
               End If
           Next i
       End If
    Next C
    MsgBox ("Données ajoutés avec succès")
End If 'ajout

'--------AMELIIORATION FIN
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

On peut encore faire plus vite si vous voulez mais cela me semble déjà bien là

Dites moi

Cordialement

Merci beaucoup Dan,

Je vais essayer avec toutes la plage remplie pour voir ce que ça donne et je vous tiens au courant,

@Dan

Wow, je suis impressionné par la rapidité du code que vous m'avez fourni, je vous en remercie, néanmoins il me manque juste deux données à rajouter à la base de données et la vérif que aucune case en jaune ne soit pas vide avant exécution

Je vous remercie pour votre temps, vraiment

Pour la vérification de vide, c'est ok je saurais faire, par contre pour rajouter les 2 champs supplémentaires dans la BDD j'ai une idée, suffirait-il de changer le i à 7 ?

           For i = 3 To 7
               ligne = Sheets("BDD").Range("A" & Sheets("BDD").Rows.Count).End(xlUp).Row + 1
               If Not IsEmpty(Cells(23, i)) Then
                   With Worksheets("BDD")
                       .Range("A" & ligne) = Annee
                       .Range("B" & ligne) = Semaine
                       .Range("C" & ligne) = C.Value
                       Worksheets("Interface").Range(Cells(23, i), Cells(28, i)).Copy
                       .Range("D" & ligne).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

j'ai testé ça mais en fait ça chamboule tout lors du recopiage dans la BDD