Vitesse d'éxécution

Le 29/11/2020 à 08:47

Bonjour a tous.

J'ai un tableau dans lequel je fais une manipulation de rassemblement de référence sur une seule page.

Il fonctionne correctement et fait exactement ce que je veux, mais je trouve l'exécution assez lente.

Y a t il moyen de modifié cela?

A savoir que mon fichier est une extraction d'un tableau classeur bcp plus gros (Environ 35 pages avec parfois plus de 1000 références par page)

Merci déjà pour vos réponse.

10test-reu.xlsm (152.53 Ko)
Le 29/11/2020 à 10:15

Bonjour,

actuellement il m'est environ 4 secondes à pour effectuer la procédure chez moi, chef vous le fichier exemple met combien de temps ?
A savoir, les accès feuilles prennent beaucoup de temps dans une procédure, il vaut mieux récupérer les données dans des tableau "VBA" puis de travailler avec ceux ci en "mémoire vive" en créant un tableau de sortie, puis à la fin de la procédure, transférer ce tableau de sortie sur la feuille de résultat.

Personnellement je le ferais bien mais je n'ai pas saisie ce que la procédure fait...

Ensuite je ne comprend pas cette façon de faire sur les tableaux, pourquoi séparer la ligne d'entête de la ligne de filtre ? Pourquoi ne pas mettre les tableaux sous forme structuré grâce au menu "insertion tableau" ?

@ bientôt

LouReeD

Le 29/11/2020 à 10:39

Bonjour à tous,

Il y aura sûrement amélioration possible du code par un plus doué ...

Une essai ...

Option Explicit

Dim J As Integer, L As Integer
Dim k As Integer, i As Integer
Dim Last As Integer, LastGab As Integer, LastGabarit As Integer
Dim TabG, TabS

Sub reu()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    k = Sheets.Count

    For i = 2 To k
        Last = Sheets(i).Range("b" & Rows.Count).End(xlUp).Row
        LastGab = Sheets("Gabarit").Range("b" & Rows.Count).End(xlUp).Row
        TabG = Sheets("Gabarit").Range("A3:H" & LastGab)
        TabS = Sheets(i).Range("A3:H" & Last)

        For J = 1 To UBound(TabS)
            For L = 1 To UBound(TabG)
                If TabG(L, 2) = TabS(J, 2) Then
                    Exit For
                ElseIf L = UBound(TabG) Then
                    Call CopieLigne     ' << si trouve pas, va copier ligne
                End If
            Next L
        Next J
        Erase TabS
    Next i
Application.Calculation = xlCalculationAutomatic
End Sub

Sub CopieLigne()

    If Sheets("Gabarit").Range("B3") = "" Then
        LastGabarit = Sheets("Gabarit").Range("b" & Rows.Count).End(xlUp).Row + 2
    Else
        LastGabarit = Sheets("Gabarit").Range("b" & Rows.Count).End(xlUp).Row + 1
    End If
    Sheets(I).Range("A" & J + 2 & ":H" & J + 2).Copy
    Sheets("Gabarit").Cells(LastGabarit, 1).PasteSpecial
End Sub

ric

Le 29/11/2020 à 10:55

Bonjour,

une solution en tableau VBA :

Sub LRD()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim I, J, K, L, Taille, TempTab(), TabRésultat(), Trouve As Boolean
    Taille = 1
    ReDim TabRésultat(1 To 8, 1 To Taille)
    ' on boucle sur les feuilles
    For I = 2 To Worksheets.Count
        Sheets(I).Activate
        TempTab = Sheets(I).ListObjects(1).DataBodyRange.Value
        For J = 1 To UBound(TempTab)
            For K = 1 To UBound(TabRésultat, 2)
                If TempTab(J, 2) = TabRésultat(2, K) Then Trouve = True: Exit For
            Next K
            If Trouve = False Then
                For L = 1 To 8
                    TabRésultat(L, Taille) = TempTab(J, L)
                Next L
                Taille = Taille + 1
                ReDim Preserve TabRésultat(1 To 8, 1 To Taille)
            Else
                Trouve = False
            End If
        Next J
    Next I
    Sheets("Gabarit").Range("A2").Resize(UBound(TabRésultat, 2), 8) = Application.Transpose(TabRésultat)
    Sheets("GAbarit").Activate
    Sheets("GAbarit").ListObjects(1).DataBodyRange.Columns(5).ClearContents
    Application.Calculation = xlCalculationAutomatic
End Sub

Je part du principe que tous les tableaux sont sous forme structuré. Reste à vérifier si je n'ai pas fait d'erreur...
Je ne sais pas (pas essayé) si les activate de feuille sont nécessaires...

Le fichier :

6test-reu.xlsm (128.64 Ko)

@ bientôt

LouReeD

Le 29/11/2020 à 11:00

Merci pour vos réponses,

Je vais tester ça.

LouReeD

Pour répondre à ton premier message. En fait je commence avec un tableau simple sans macros et puis au fur et à mesure, je me rend compte que des taches sont répétitives, puis je fais des macros mais je ne change pas la présentation.

C'est un défaut que j'ai mais je n'arrive pas a projeté ce que je veux des le début...

Le 29/11/2020 à 11:14

Ok, mais pour ce qui est des tableaux structurés, je pense que c'est le minimum, même sans macro, à faire avec des "bases de données", cela apporte beaucoup de facilité de gestion comme la recopie des formules dans les colonnes automatiquement, la recopie des MFC, l'ajout de ligne ou de colonne automatique, juste en inscrivant les nouvelles données en-dessous du tableau ou juste à droite etc... En plus au niveau VBA cela est un "Objet" sur lequel on peut travailler facilement.

Moi je m'y suis mis depuis peu, je ne maitrise pas encore tout, mais déjà ça fait gagner du temps d'exécution, tout comme le fait de travailler avec des tableaux VBA sans accès feuilles si ce n'est au début pour prendre les données et à la fin pour les transférer.

Ceci dit, faut voir si le code fonctionne car il ne reste qu'environ 800 lignes une fois fait...

@ bientôt

LouReeD

Le 29/11/2020 à 11:55

Alors mon code repart de "0" à chaque fois. Le code ci dessous, récupère le tableau de la feuille Gabarit et le transpose pour pouvoir travailler avec les ReDim Preserve, et comme cela la recherche de nouvelles références se fait "uniquement" sur celles non encore inscrites... A voir si cela fait gagner du temps :

Option Base 1

Sub LRD()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim I, J, K, L, Taille, TempTab(), TabGabarit(), TabRésultat(), Trouve As Boolean
    TabGabarit = Sheets("Gabarit").ListObjects(1).DataBodyRange.Value
    TabRésultat = TransposeTab(TabGabarit)
    Taille = UBound(TabRésultat, 2)
    ReDim Preserve TabRésultat(1 To 8, 1 To Taille)
    For I = 2 To Worksheets.Count
        TempTab = Sheets(I).ListObjects(1).DataBodyRange.Value
        For J = 1 To UBound(TempTab)
            For K = 1 To UBound(TabRésultat, 2)
                If TempTab(J, 2) = TabRésultat(2, K) Then Trouve = True: Exit For
            Next K
            If Trouve = False Then
                Taille = Taille + 1
                ReDim Preserve TabRésultat(1 To 8, 1 To Taille)
                For L = 1 To 8
                    TabRésultat(L, Taille) = TempTab(J, L)
                Next L
            Else
                Trouve = False
            End If
        Next J
    Next I
    Sheets("Gabarit").Range("A2").Resize(UBound(TabRésultat, 2), 8) = Application.Transpose(TabRésultat)
    Sheets("GAbarit").ListObjects(1).DataBodyRange.Columns(5).ClearContents
    Application.Calculation = xlCalculationAutomatic
End Sub

Function TransposeTab(T)
    Dim T2, I, J
    ReDim T2(UBound(T, 2), UBound(T, 1))
    For I = 1 To UBound(T)
        For J = 1 To UBound(T, 2)
            T2(J, I) = T(I, J)
        Next J
    Next I
    TransposeTab = T2
End Function

Il y a ici une fonction Transpose afin de "retourner" le tableau gabarit, afin d'avoir les "lignes" en deuxième position car VBA ne sait faire les ReDim Preserve que sur la dernière dimension d'un tableau. J'ai aussi modifié l'ordre de "croissance" du tableau résultat afin de ne pas avoir une ligne vide qui se rajoute à chaque clic sur le bouton !

@ bientôt

LouReeD

Rechercher des sujets similaires à "vitesse execution"