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 !

[patricktoulon]

Bonjour
jijie
je n'ai pas regarder ton fichier encore mais déjà je peut te dire que si tu veut transformer ceci

83 toulon 83000
06 nice 06120
06 menton 06321
83 la seyne sur mer 83450
13 MARSEILLE 13800
83 LAVALETTE 83145

EN CECI PAR EXEMPLE

83 toulon 83000 83 la seyne sur mer 83450 83 LAVALETTE 83145
06 nice 06120 06 menton 06321
13 MARSEILLE 13800

IL TE SUFFIT DE
METTRE TA PLAGE DANS UN TABLEAU
tablo=range("AZ:XY")'avec le end(xlup) serait le bien venu
ensuite entrer ton tableau dans le dictionnaire par le teste de l'existance
si ca existe tu ajoute a la cle les 3 cellule sinon tu ajoute une ligne au dico
tout simplement
il te faut un exemple ou tu a compris

[jijie]

IL TE SUFFIT DE
METTRE TA PLAGE DANS UN TABLEAU
tablo=range("AZ:XY")'avec le end(xlup) serait le bien venu
ensuite entrer ton tableau dans le dictionnaire par le teste de l'existance
si ca existe tu ajoute a la cle les 3 cellule sinon tu ajoute une ligne au dico
tout simplement
il te faut un exemple ou tu a compris

Pourtant si je regarde :

Scripting.dictionary est un outil VBA qui stocke en mémoire vive une liste de paires d'éléments (clé,élément).

donc dans un dictionnaire: on aurra bien autant de clé que de département, mais dans mon dictionnaire je ne pourrais pas avoir X villes et CP car on à un seul élément!

Ds le code que je donne le résultat du tablo2 est colonneA Département colonneB ville1 colonneC CP1 ColonneD ville2..............

Il me semble que dans ton exemple tu fait tout dans la colonneA?

[boisgontierjacques]

Bonsoir,


1 seconde

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
 
Sub ListeInverses()
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("liste")
  a = f1.Range("a2:c" & f1.[A65000].End(xlUp).Row).Value
  For i = LBound(a) To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) & "|" & a(i, 2) & "|" & a(i, 3)
  Next i
  ligne = 2
  Set f2 = Sheets("feuil2")
  For Each c In d.Keys
    f2.Cells(ligne, "a") = c
    a = Split(d.Item(c), "|")
    f2.Cells(ligne, "a").Offset(, 1).Resize(, UBound(a) + 1) = a
    ligne = ligne + 1
  Next c
End Sub

Ne fonctionne pas en 2003 (pas assez de colonnes)

>donc dans un dictionnaire: on aurra bien autant de clé que de département, mais dans mon dictionnaire je ne pourrais pas avoir X villes et CP car on à un seul élément!

FAUX

Un élément de dictionnaire peut être un tableau.

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
 
Sub EssaiDictionnaire()
  Set d = CreateObject("Scripting.Dictionary")
  ville = "Lyon"
  d.Item("Martin") = Array(ville, 5000, #12/10/1980#)
  MsgBox d.Item("Martin")(0)
 
  Dim a(1 To 3)
  a(1) = "Paris": a(2) = 5000: a(3) = #12/13/1945#   ' tableau a()
  d.Item("Dupont") = a
  MsgBox d.Item("Dupont")(2)
  b = d.Item("Dupont")              ' éléments de Dupont dans un tableau b()
  MsgBox b(3)
  For Each c In d.Item("Dupont")
    MsgBox c
  Next c
End Sub

Jacques Boisgontier

[patricktoulon]

je ne me suis pas occupé du transfert sur la feuille mais en gros je fonction comme ca
dans la ligne du msgbox a la fin change le département et tu aura toutes les villes corespondant
moins de 3 secondes chez moi

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
Option Base 1
Sub rassemble_les_ville_de_meme_departement()
   Dim tablo, dico1, dico2
   Set dico1 = CreateObject("Scripting.Dictionary")
  With Sheets("Liste")
  'on met tout dans le tablo d'un coup
   tablo = .Range("A2:C" & .Range("a" & Rows.Count).End(xlUp).Row)
   End With
 
   For i = 1 To UBound(tablo)
     If Not dico1.Exists(tablo(i, 1)) Then
           dico1(tablo(i, 1)) = tablo(i, 2) & tablo(i, 3) & "!!!!!!"
      Else
      dico1(tablo(i, 1)) = dico1(tablo(i, 1)) & tablo(i, 2) & "!!!!!!" & tablo(i, 3)
   End If
   Next
 
 
  MsgBox dico1("CALVADOS")
 
  End Sub

[jijie]

Merci Jacques,

Avant que je décortique ton code j'ai une erreur exécution 1004 ici:

Code :

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

    f2.Cells(ligne, "a").Offset(, 1).Resize(, UBound(a) + 1) = a

Si je comprend bien on fait un tableau dans un élément?

[boisgontierjacques]

>Avant que je décortique ton code j'ai une erreur exécution 1004 ici:

Il faut prendre le 2eme fichier (Excel 2010)

Je n'ai pas utilisé un tableau comme élément de dictionnaire sur cet exemple.
J'ai concaténé les communes et codes postaux dans une chaîne que j'ai ensuite splité dans un tableau.

http://boisgontierjacques.free.fr/fi...Inverses3.xlsm

Jacques Boisgontier

[jijie]

Merci à vous deux !

Même si je pensais maitriser un peu plus les tableaux, autant dire qu'il me reste encore un peu de perfectionnement! La version de jaques fonctionne en 1.25s ! Bien vu les Split, ça ouvre encore des possibilités !

Patrick: j'ai réussi à adapter ta solution avec a peu près le même temps! Il faut quand même que tu avoue que je commence à maîtriser les tableau! enfin un peu !

sincèrement un grand grand merci à vous !

[patricktoulon]

re
tiens regarde cet exemple
il illustre ce que jacques t a dis précédemment
en effet un élément d'un dico peut parfaitement être un array ici en l'occurrence c'est une plage
en même temps ca te donne une autre approche sur l'utilisation d'un dico

en effet ici je ne mémorise pas les valeur mais la plage(objet range)

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
Sub rassemble_les_ville_de_meme_departement2()
    Dim tablo, dico1, dico2, tableau, derligfeuil2
    Set dico1 = CreateObject("Scripting.Dictionary")
    Set dico2 = CreateObject("Scripting.Dictionary")
    With Sheets("Liste")
        'on met tout dans le tablo d'un coup
        tablo = .Range("A2:C" & .Range("a" & Rows.Count).End(xlUp).Row)
    End With
    For i = 1 To UBound(tablo)
 
        If Not dico1.Exists(tablo(i, 1)) Then
            dico1(tablo(i, 1)) = "B" & i + 1 & ":"
            dico2(tablo(i, 1)) = ""
        Else
            dico1(tablo(i, 1)) = Split(dico1(tablo(i, 1)), ":")(0) & ":" & "C" & i + 1
            dico2(tablo(i, 1)) = Range(Split(dico1(tablo(i, 1)), ":")(0) & ":" & "C" & i + 1)
 
        End If
    Next
    'ici on peut boucler sur le tablo1 pour transposer le dico2
    'derligfeuil2 = Sheets(2).Range("A" & Sheets(2).Range("a" & Rows.Count).End(xlUp).Row)
    'for each.....
 
    Sheets(2).Range("A" & 1).Resize(2, 500) = Application.Transpose(dico2("AIN"))
    'exemple affiche l'element 3 du tableau du departement de "AIN"
    'comme te l'adit jacques une cle de dico peut parfaitement etre un array ici en l'occurence une plage
    MsgBox dico2("AIN")(3, 1)
'next...........
End Sub

merci a jacques pour me l'avoir rappeler