Vitesse d'éxécution
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.
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
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
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 :
@ bientôt
LouReeD
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...
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
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