Réduire temps d’exécution d'une macro

Version imprimable

Bonjour;

J'ai un tableau Excel qui avoisine les 50 000 lignes, ce tableau contient des lignes en double dans chaque ligne on trouve un code et une quantité mon objectif c'est de faire la somme des quantités de chaque code et les mettre dans un autre tableau.
Ma macro fonctionne très bien mon soucié qu'elle prend beaucoup de temps ( elle dépasse les 45 min des fois )

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
Application.ScreenUpdating = False 'juste pour arrêter affichage écran et améliorer le temps d'exécution du macro 
'***********************************Effacer Enciennes Données
With Sheets("feuil3")
.Cells.ClearContents
End With
Dim T
Set dico = CreateObject("Scripting.dictionary")
With Sheets("Quantité produite")
        dernl = .Range("D" & .Rows.Count).End(xlUp).Row
                For j = 1 To dernl
                 x = .Range("A" & j) & ";" & .Range("B" & j) & ";" & .Range("C" & j) & ";" & .Range("D" & j) & ";" & .Range("E" & j)
                 dico(x) = .Range("A" & j) & ";" & .Range("B" & j) & ";" & .Range("C" & j) & ";" & .Range("D" & j) & ";" & .Range("E" & j)
                Next j
Cle = dico.Keys
L = 1
TABLO = .Range("A1", "F" & .Range("F" & .Rows.Count).End(xlUp).Row)
End With
 
With Sheets("feuil3")
    For i = 0 To dico.Count - 1
        T = Split(dico(Cle(i)), ";")
        .Cells(L, 1).Value = Cle(i)
        .Cells(L, 1).Value = T(0)
        .Cells(L, 2).Value = T(1)
        .Cells(L, 3).Value = T(2)
        .Cells(L, 4).Value = T(3)
        .Cells(L, 5).Value = T(4)
        L = L + 1
    Next
dernligne = .Range("D" & .Rows.Count).End(xlUp).Row
 
Dim somme As Variant
For j = 1 To dernligne
   For i = LBound(TABLO, 1) To UBound(TABLO, 1)
             If .Cells(j, 5) = TABLO(i, 5) And .Cells(j, 4) = TABLO(i, 4) Then
                 somme = somme + TABLO(i, 6)
                .Cells(j, 6) = somme
              End If
      Next i
     somme = 0
 Next j
End With

Je compte sur votre aide , Merci d'avance

20/06/2019, 10h30
BENNASR

bonjour

Citation:

J'ai un tableau Excel qui avoisine les 50 000 lignes, ce tableau contient des lignes en double dans chaque ligne on trouve un code et une quantité mon objectif c'est de faire la somme des quantités de chaque code et les mettre dans un autre tableau.

n'est pas claire au moins pour moi mais si tu insère un TCD çe ne résolu pas ton problème??
20/06/2019, 10h43
le_dabbabi

Citation:

Envoyé par BENNASR

bonjour

n'est pas claire au moins pour moi mais si tu insère un TCD çe ne résolu pas ton problème??

Merci pour votre réponse j’espère que ce poste va vous faire un refresh mémoire ;)
https://www.developpez.net/forums/d1...omme-cellules/
20/06/2019, 10h58
BENNASR

La vérité je souviens que de ce jolie drapeau avec l'étoile et le croissant que j'aime beaucoup .... oublier est le fait du temps et de la vieillesse :aie:
je vais voir qu'est ce qu'on peut améliorer dans ce code pour une base de 50 milles lignes sur Excel !!!
ne fermez pas les yeux devant le risque de gérer cette gigantesque base des données avec Excel
a+

la solution à tout le bricolage que j'ai fais lors de mon ancienne intervention se trouve dans le SUPER TUTORIEL du Grand MONSIEUR boisgontierjacques :plusser: :plusser: :plusser:

Citation:

http://boisgontierjacques.free.fr/pa....htm#TotalCout

à remplacer la totalité du code par :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub testbildic()
Application.ScreenUpdating = False
Dim f As Worksheet
Dim f2 As Worksheet
Set f = Sheets("feuil1")
Set f2 = Sheets("feuil2")
f2.Cells.ClearContents
 f2.Cells(1, 1).Resize(1, 6) = Array(f.Cells(1, 1), f.Cells(1, 2), f.Cells(1, 3), f.Cells(1, 4), f.Cells(1, 5), f.Cells(1, 6))
  Set d = CreateObject("Scripting.Dictionary")
  TblBD = f.Range("A2:F" & f.Range("A" & Rows.Count).End(xlUp).Row)
  For i = 1 To UBound(TblBD)
    clé = TblBD(i, 1)  & "|" &  TblBD(i, 2)  &  "|"  &  TblBD(i, 3)  & "|" & TblBD(i, 4)  &  "|"  &  TblBD(i, 5)
    d(clé) = d(clé) + TblBD(i, 6)
  Next i
  f2.Range("A2").Resize(d.Count) = Application.Transpose(d.keys)
  f2.Range("f2").Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  f2.Range("A2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
Application.ScreenUpdating = True
f2.Select
End Sub

A tester et dire si ça arrange définitivement ton problème de temps d'exécution

21/06/2019, 15h31
le_dabbabi

ça fonctionne très bien Merci