Discussion :

[jijie]

Bonjour le forum!

Donc toujours sur les essai tableaux, je reviens vers vous afin réaliser un challenge ! ( et pour moi ça l'est)

Sur un autre post j'avais présenter une réponse qui était très lente!

Le principe sur le fichier joint une feuille liste avec en

colonne A les départements ( Autant que de villes soit environ 38000 lignes)
colonne B les Villes (donc en colonneA se trouve le département correspondant à la ville)
colonne C les CP

donc nous avons sur la feuille liste 3 colonnes

Le but de la macro est de faire une ligne par département et dans chaque ligne ville1 - Cp1 - Ville2- CP.........

J'ai commencé par faire un essai

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Option Explicit
 
 
Sub ESSAI2()
Dim cel As Variant
Dim unique As New Collection
Dim NbExiste As Long
Dim TaBlo() As Variant
Dim i, f, r, e, s, ligne As Long
Dim Titre As Variant
Dim DerLigne As Integer
Dim sngChrono As Single
 
 
Application.ScreenUpdating = False 'désactive la mise à jour de l'écran
 
sngChrono = Timer
 Application.ScreenUpdating = False
' on recherche le nbre d'élément unique et la dimention du tableau
 
On Error Resume Next
For Each cel In Sheets("liste").Range("A2:A" & [A65000].End(xlUp).Row)
 
    unique.Add cel.Value, CStr(cel.Value)
    NbExiste = Application.CountIf(Sheets("liste").Range("a2:A" & [A65000].End(xlUp).Row), cel) ' recherche le nbre de fois ou il existe
 
    If s < NbExiste Then s = NbExiste
 
Next cel
On Error GoTo 0
 
sngChrono = Timer - sngChrono
 
MsgBox "Temps d'execution du code en : " & CStr(sngChrono * 1) & " secondes"
 
' unique.count est le nbre de lignes du tableau
s = (s * 2) + 1 ' e est la dimention du tableau
 
 
'on charge le tableau
ReDim TaBlo(unique.Count - 1, s)
r = 0
 
For i = 1 To unique.Count
  NbExiste = 0
  ligne = 1
  e = 1
  Titre = unique(i)
  NbExiste = Application.CountIf(Range("a2:A" & [A65000].End(xlUp).Row), unique(i)) ' recherche le nbre de fois ou il existe
 
 
    For f = 1 To NbExiste
 ' -------------------------
 
Dim C2 As Variant
 
 
'Nom du cpt a chercher
 
'recherche du cpt dans la colonne BA
Set C2 = Sheets("liste").Range("A" & ligne + 1 & ":A" & [A65000].End(xlUp).Row).Find(What:=Titre, LookAt:=xlWhole)
 
'Si le nom n'existe pas alors rien
If C2 Is Nothing Then
 
'Si le produit existe on sélectionne la cellule
Else
 
 ligne = C2.Row
        TaBlo(r, 0) = Titre
        TaBlo(r, e) = C2.Offset(0, 1)
        e = e + 1
        TaBlo(r, e) = C2.Offset(0, 2)
        e = e + 1
 
 
End If
 
 
 
 
 
 
 
    Next f
  r = r + 1
 
 
Next i
 
' on note le tableau dans la feuille2
 
    Sheets("feuil2").Cells.ClearContents ' on efface la feuille2
 
Dim coloNNE As Variant
 
coloNNE = Split(Columns(s).Address(ColumnAbsolute:=False), ":")(1)
 
Sheets("feuil2").Range("A2:" & coloNNE & r + 1).Value = TaBlo
 
'Code à chronométrer
sngChrono = Timer - sngChrono
Application.ScreenUpdating = True 'active la mise à jour de l'écran
 
MsgBox "Temps d'execution du code en : " & CStr(sngChrono * 1) & " secondes"
 
End Sub

Puis par une remarque de Patrick me disant :

et ensuite travailler sur ce tableau plutôt que tes cells

quand tu travaille avec des tableau ou dictionnaire tu dois travailler le plus possible en mémoire

Donc j'ai essayer ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Option Explicit
 
 
Option Base 1
 
Sub Essai3()
Dim cel As Variant
Dim NbExiste As Long
Dim TaBlo() As Variant
Dim i, f, r, e, s, ligne As Long
Dim sngChrono As Single
Dim mondico As Variant
Dim tablo2 As Variant
 
    Sheets("feuil2").Cells.ClearContents ' on efface la feuille2
 
Application.ScreenUpdating = False 'désactive la mise à jour de l'écran
 
sngChrono = Timer
 
 
TaBlo = Range("a1:c" & Sheets("liste").Range("a" & Rows.Count).End(xlUp).Row) ' on charge le tablo
 
 
  Set mondico = CreateObject("Scripting.Dictionary")
s = 1
For i = 1 To UBound(TaBlo)
            If Not mondico.Exists(TaBlo(i, 1)) Then
                mondico.Add (TaBlo(i, 1)), TaBlo(i, 2)
                  NbExiste = Application.CountIf(Range("a2:A" & [A65000].End(xlUp).Row), TaBlo(i, 1)) ' recherche le nbre de fois ou il existe
            If s < NbExiste Then s = NbExiste
            Else
                'Cas ou existe déjà Incrémente'on ajoute les points a l'item deja representant  representant (tablo(i,1)
               ' mondico(TaBlo(i, 1)) = mondico(TaBlo(i, 1)) + TaBlo(i, 2)
            End If
        Next i
 
 s = (s * 2) + 1 'dimmention maxi tablo2 car on cpte 2 éléments par
 
ReDim tablo2(mondico.Count - 1, s)
cel = mondico.Keys
 
e = 1 'ligne tablo2
 
For i = 1 To mondico.Count - 1
 r = 2 ' position dimmention tablo2
  For f = 1 To UBound(TaBlo)
 
    If TaBlo(f, 1) = cel(i) Then
      tablo2(e, 1) = cel(i)
      tablo2(e, r) = TaBlo(f, 2)
 
      r = r + 1 ' repositionne dimmention
      tablo2(e, r) = TaBlo(f, 3)
 
      r = r + 1 ' repositionne dimmention
 
    End If
   Next f
  e = e + 1 ' on passe à la ligne tablo2
 Next i
 
 
   Dim coloNNE As Variant
coloNNE = Split(Columns(s).Address(ColumnAbsolute:=False), ":")(1)
Sheets("feuil2").Range("A2:" & coloNNE & mondico.Count).Value = tablo2
 
sngChrono = Timer - sngChrono
Application.ScreenUpdating = True 'active la mise à jour de l'écran
 
MsgBox "Temps d'execution du code en : " & CStr(sngChrono * 1) & " secondes"
 
 
End Sub

BEAUCOUP PLUS RAPIDE ! environ 3s

Seulement avec ça je suis obligé de rester sur la feuille liste :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

TaBlo =Range("a1:c" & Sheets("liste").Range("a" & Rows.Count).End(xlUp).Row) ' on charge le tablo

et ceci ne fonctionne pas :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

TaBlo = Sheets("liste").Range("a1:c" & Sheets("liste").Range("a" & Rows.Count).End(xlUp).Row) ' on charge le tablo

de plus la variable Nbexiste est utilisé pour connaitre la dimention du tablo2, mais avec la remarque de Patrick comment faire la même chose avec sur un tableau?

Enfin Marc je te laisse le fichier en PJ je reste tout ouïe !