Optimisation Boucle avec tableau dynamique

Version imprimable

1 pièce(s) jointe(s)

Bonjour à tous,

Je viens vers vous car j'ai codé une macro qui fonctionne, néanmoins je suis très très loin d'etre un pro de la macro.
Elle n'est donc pas optimisée, et pour des tableaux de 1000 lignes je dois attendre 20-25 minutes de traitement.

Je voulais donc savoir s'il existait un moyen d'améliorer le fonctionnement de cette boucle.
J'ai vu qu'il était possible de passer par des tableaux fictifs, mais je suis incapable de l'adapter a mon propre cas.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
           dernLigne = Cells(Rows.Count, 1).End(xlUp).Row - 1
 
 
            For a = 1 To dernLigne
 
            '___________________________transfert de la reference __________________________________________
            Sheets("ecran utilisateur").Select
            Cells(3, 3).Select
            Selection.Copy
 
            Sheets("archivage").Select
            Cells(Rows.Count, 1).End(xlUp)(2).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Application.ScreenUpdating = True
 
            '___________________________transfert du statut et du poids enregistre __________________________________________
            Sheets("ecran utilisateur").Select
            Range("C13:k13").Select
            Selection.Copy
            Sheets("archivage").Select
            Cells((Range("A1").End(xlDown).Row), 2).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Cells((Range("A1").End(xlDown).Row), 11).Value = Now
 
            Cells((Range("A1").End(xlDown).Row) + 1, 1).Select
 
                i = Worksheets("ecran utilisateur").Cells(17, 6).Value
                Worksheets("ecran utilisateur").Range("C2").Formula = "=archivage!A" & i
                Worksheets("ecran utilisateur").Cells(17, 6).Value = i + 1
           Next

Je vous joins également le fichier sur lequel je travaille... (macro du module 4, le bouton situé sur la cellule F18)
Pièce jointe 618126
Si vous avez des idées, je vous en remercie.

Cdt,
Adrien

1 pièce(s) jointe(s)

pour completer mon propos, voici une tentative d'optimisation de ma part : c'ets pas encore la panacée bien que clairement plus rapide.

le probleme, c'est que pour je ne sais quelle raison, la cellule C13 ne se copie pas alors que toutes les autres fonctionnent :lol:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
   Sub Fonction()
 
            Dim i
            Dim safe As Boolean
            Dim dernLigne As Integer
 
 
            With ThisWorkbook.Worksheets("ecran utilisateur")
                .Range("C2").Formula = "=archivage!A2"
                .Range("F17").Formula = "=3"
                .Range("C4").Formula = "=VLookup(C3, archivage!A:J,4,false)"
                .Range("C5").Formula = "=VLookup(C3, archivage!A:J,5,false)"
                .Range("C6").Formula = "=VLookup(C3, archivage!A:J,6,false)"
                .Range("C7").Formula = "=VLookup(C3, archivage!A:J,7,false)"
                .Range("C8").Formula = "=VLookup(C3, archivage!A:J,8,false)"
                .Range("C9").Formula = "=VLookup(C3, archivage!A:J,9,false)"
                .Range("C10").Formula = "=VLookup(C3, archivage!A:J,10,false)"
 
            End With
 
            dernLigne = Cells(Rows.Count, 1).End(xlUp).Row - 1
 
 
            '___________________________Condition d'activation de la macro __________________________________________
            Sheets("ecran utilisateur").Select
            If Cells(2, 3) = "" Or Cells(3, 3) = "" Or Cells(4, 3) = "" Or Cells(5, 3) = "" Or Cells(6, 3) = "" Or Cells(7, 3) = "" Or Cells(8, 3) = "" Or Cells(9, 3) = "" Then
 
            Else
 
            For a = 1 To dernLigne
 
            '___________________________transfert de la reference __________________________________________
             'Selection
 
            Sheets("archivage").Cells(Rows.Count, 1).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("C3").Value
            Sheets("archivage").Cells(Rows.Count, 2).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("C13").Value
            Sheets("archivage").Cells(Rows.Count, 3).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("D13").Value
            Sheets("archivage").Cells(Rows.Count, 4).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("E13").Value
            Sheets("archivage").Cells(Rows.Count, 5).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("F13").Value
            Sheets("archivage").Cells(Rows.Count, 6).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("G13").Value
            Sheets("archivage").Cells(Rows.Count, 7).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("H13").Value
            Sheets("archivage").Cells(Rows.Count, 8).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("I13").Value
            Sheets("archivage").Cells(Rows.Count, 9).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("J13").Value
            Sheets("archivage").Cells(Rows.Count, 10).End(xlUp)(2).Value = Sheets("ecran utilisateur").Range("K13").Value
            Sheets("archivage").Cells(Rows.Count, 11).End(xlUp)(2).Value = Now
 
            '___________________________transfert du statut et du poids enregistre __________________________________________
 
 
 
                i = Worksheets("ecran utilisateur").Cells(17, 6).Value
                Worksheets("ecran utilisateur").Range("C2").Formula = "=archivage!A" & i
                Worksheets("ecran utilisateur").Cells(17, 6).Value = i + 1
           Next
 
        End If

Pièce jointe 618127

Optimisation

J'ai simplifié votre code ainsi:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
 
Sub maFonction()
 
    Dim I, J, k As Integer
    Dim c As Range
    Dim safe As Boolean
    Dim dernLigne, x As Long
    Dim shUtilisateur, shArchivage As Worksheet
    Dim Deb, dur As Date
 
    Deb = Now
    Set shUtilisateur = ThisWorkbook.Worksheets("ecran utilisateur")
    Set shArchivage = ThisWorkbook.Worksheets("archivage")
 
    Application.ScreenUpdating = False
    Application.Cursor = xlWait
    On Error GoTo Sortie
 
    With shUtilisateur
        .Range("C2").Formula = "=archivage!A2"
        .Range("F17") = 3
        For J = 4 To 10
            .Cells(J, 3).Formula = "=VLookup(C3, archivage!A:J," & J & ",False)"
            'Conseil: après entrée des formules, les transformer en valeurs pour gagner en performance !
        Next J
    End With
 
    '___________________________Condition d'activation de la macro _________________________________
    
    With shUtilisateur
        For Each c In shUtilisateur.Range("C2:C10")
            If c.Value = "" Or c.Value = 0 Or WorksheetFunction.IsNA(c) Then
                MsgBox "La donnée en '" & c.Address & "' est manquante !"
                Exit Sub
            End If
        Next c
    End With
 
     dernLigne = shArchivage.Cells(Rows.Count, 1).End(xlUp).Row
     x = dernLigne + 1
     With shArchivage
         .Unprotect
 
         For J = 1 To dernLigne
            '___________________________transfert de la reference __________________________________
            .Cells(x, 1).Value = shUtilisateur.Range("C3").Value
            For k = 2 To 11
                .Cells(x, k).Value = shUtilisateur.Cells(13, k + 1).Value
            Next k
            .Cells(x, 11).Value = Now()
            x = x + 1
            '___________________________transfert du statut et du poids enregistre _________________
                    
            I = shUtilisateur.Cells(17, 6).Value
            shUtilisateur.Range("C2").Formula = "=archivage!A" & I
            shUtilisateur.Cells(17, 6).Value = I + 1
        Next J
    End With

29/04/2022, 10h23
Im Dri

Bonjour,

Merci de votre réponse, ca m'est très utile.

J'ai essayé plusieurs fois votre code, mais cela me retourne différentes erreurs.
Si je le colle tel quel, je trouve une erreur de compilation au niveau de

Code:

On Error GoTo Sortie

Si j'enleve cette ligne de code, la macro marche parfaitement et me retourne les bons résultats.
Néanmoins elle ne s'arrête jamais et charge indéfiniment, je suis obligé de fermer excel de force
29/04/2022, 11h01
Im Dri

c'ets bon, j'ai compris d'ou venait le souci et c'est corrigé.

Grace a cette macro je mets 1 minute pour traiter 1000 lignes, c'est 20 fois plus rapide, merci beaucoup :mouarf::mouarf:
04/05/2022, 16h43
Pierre Fauconnier

Salut.

Tu gagnerais déjà à travailler avec des tableaux structurés => https://fauconnier.developpez.com/tu...ux-structures/

On ne sait pas quelle solution a été trouvée, mais une solution qui traite 1000 lignes à la minute, ce n'est pour moi pas une solution. Dommage.

Cela dit, au lieu de multiplier les RECHERCHEV, tu aurais intérêt à chercher l'index de la ligne avec un EQUIV puis de t'en servir pour récupérer les données. Ca accélérerait le processus.

Si tu expliques en français ce que tu souhaites réaliser et que tu place une ou l'autre copie d'écran significative, on pourra probablement t'aider à améliorer le temps de traitement.