XL 2010 Passer de Dico à Array avec Split

cp4

cp4

XLDnaute Barbatruc
Bonsoir:),

J'ai eu beau chercher je ne suis pas parvenu à trouver une réponse.
J'ai utilisé un dictionnaire pour faire la somme pour chaque personne (nom, prénom dans les colonnes différentes).
Jusque là, pas de problème. Maintenant, je voudrais repasser vers un autre tableau pour séparer les noms, prénoms et le montants.
Je crois savoir que la fonction split est tout indiquée à mon problème. Mais, j'avoue que je suis perdu.
VB: 
For i = 1 To UBound(Tb)
d(Tb(i, 2) & "|" & Tb(i, 3)) = d(Tb(i, 2) & "|" & Tb(i, 3)) + Tb(i, 16)
Next i

En vous remerciant par avance.
 
Solution
Dranreb
Moi je faisais comme ça :
VB: 
Sub EssaiDranreb()
   Dim TDon(), LDon As Long, TRés(), LRés As Long, Clé As String, Dic As New dictionary
   TDon = ActiveSheet.[A1].CurrentRegion.Value
   ReDim TRés(1 To UBound(TDon, 1), 1 To 3)
   For LDon = 1 To UBound(TDon, 1)
      Clé = TDon(LDon, 2) & "|" & TDon(LDon, 3)
      If Dic.exists(Clé) Then
         LRés = Dic(Clé)
         TRés(LRés, 3) = TRés(LRés, 3) + TDon(LDon, 16)
      Else
         LRés = Dic.Count + 1: Dic(Clé) = LRés
         TRés(LRés, 1) = TDon(LDon, 2)
         TRés(LRés, 2) = TDon(LDon, 3)
         TRés(LRés, 3) = TDon(LDon, 16)
         End If
      Next LDon
   ActiveSheet.[V1].Resize(Dic.Count, 3) = TRés
   End Sub
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Résultat: 7 secondes et des poussières
Ce m'a donné le temps de pondre ceci ;)
VB: 
Sub InitStaple()
Dim r As Range
Set r = Range("A2:P100000")
Application.ScreenUpdating = False
r = _
Array("=row()-1", "=""Toto-"" & RANDBETWEEN(1,10000)", "=SUBSTITUTE(RC[-1],""o"",CHOOSE(RANDBETWEEN(1,3),""u"",""i"",""a""))", Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, Empty, "=RANDBETWEEN(1,10000)/100")
r = r.Value
End Sub
;)
Ou cette variante
VB: 
Sub InitStaple_II()
Dim r As Range: Set r = Range("A2:D100000")
Application.ScreenUpdating = False
r = Array("=row()-1", "=""Toto-"" & RANDBETWEEN(1,10000)", "=SUBSTITUTE(RC[-1],""o"",CHOOSE(RANDBETWEEN(1,3),""u"",""i"",""a""))", "=RANDBETWEEN(1,10000)/100")
r = r.Value
Columns("D:O").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Staple1600 à dit:
Ce m'a donné le temps de pondre ceci
Cliquez pour agrandir...

Je pense qu'il vaut mieux utiliser au maximum les fonctions natives de VBA plutôt que de passer par des fonctions Excel (dans de rares cas, ce n'est pas vrai).
Ici la version (presque entièrement) en mémoire prend environ 1 sec. (contre environ 3,9 sec. pour l'autre).
 

Pièces jointes

  • cp4- init- v1.xlsm
    18.3 KB · Affichages: 20
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

=>mapomme
L'eus-tu pensé sans notre échange en MP? ;)
Echange qui m'aura permis de faire juste un copier/coller pour tester. ;)
VB: 
Sub Initmapomme()
Const nbrlig = 100000
Dim i&, c$, Ti
   Ti = Timer
   ReDim t(1 To nbrlig, 1 To 4)
   Randomize
   For i = 1 To UBound(t)
      t(i, 1) = i + 1
      t(i, 2) = "Toto" & (1 + Int(10000 * Rnd))
      Select Case Int(3 * Rnd)
         Case 0: t(i, 3) = Replace(t(i, 2), "o", "a")
         Case 1: t(i, 3) = Replace(t(i, 2), "o", "i")
         Case 2: t(i, 3) = Replace(t(i, 2), "o", "u")
      End Select
      t(i, 4) = Int(10000 * Rnd) / 100#
   Next i
   Application.ScreenUpdating = False
   Cells(2, "a").Resize(nbrlig, 3) = t
   Cells(2, "p").Resize(nbrlig) = Application.Index(t, 0, 4)
   MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub
Mon Excel tousse.
Je redémarre mon PC et reviens donné le résultat du MsgBox.
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Accro
Bonsoir,
Je pense que l'on peux découper en une seul fois la Keys ?
Voici Mon code :
VB: 
Option Explicit
' code nécessite que la référence "Microsoft Scripting Runtime" soit activée
Sub essai2()
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim temp As Variant
Dim d As New Scripting.Dictionary
    Set d = New Dictionary
Dim i As Double

For i = LBound(Tb) + 1 To UBound(Tb)
    If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
        d(Tb(i, 2) & "|" & Tb(i, 3)) = d(Tb(i, 2) & "|" & Tb(i, 3)) + Tb(i, 16) ' d.Keys(0) =  d.Items(0)
    Else
        d(Tb(i, 2) & "|" & Tb(i, 3)) = d(Tb(i, 2) & "|" & Tb(i, 3)) + Tb(i, 16) ' d.Keys(0) =  d.Items(0)
    End If
Next i

' Comment Découper la clef (Split) ?
[V1].Resize(d.Count) = Application.Transpose(d.Keys) ' Comment split en 1 fois (pour 2 colonnes)
[w1].Resize(d.Count) = Application.Transpose(d.Items)
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re,

•>Laurent950
Tu n'as pas du regarder le code de mapomme
(je me permets de le reposter ici)
Enrichi (BBcode): 
Sub tabloSomm()     'mapomme
Dim t, dico As New Dictionary, i&, clef, ii&, j&, Ti

   Ti = Timer
   t = Range("a1").CurrentRegion
  Set dico = CreateObject("scripting.dictionary")
   dico.CompareMode = TextCompare
   For i = 2 To UBound(t)
      clef = Join(Array(t(i, 2), t(i, 3)), "|")
      If Not dico.Exists(clef) Then
         ii = dico.Count + 1
         dico(clef) = ii
         t(ii, 1) = t(i, 2): t(ii, 2) = t(i, 3): t(ii, 3) = t(i, 16)
      Else
         ii = dico(clef)
         t(ii, 3) = t(ii, 3) + t(i, 16)
      End If
   Next i

   ReDim r(1 To dico.Count, 1 To 3)
   For i = 2 To dico.Count + 1
      For j = 1 To 3
         r(i - 1, j) = t(i - 1, j)
      Next j
   Next i
   With Range("r1")
      .CurrentRegion.ClearContents: .Resize(UBound(r), 3) = r: .CurrentRegion.Borders.LineStyle = xlContinuous
   End With
   MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
bonjour a tous
de bon matin a la fraîche
et si on économisez encore un peu
a partir du moment ou on réagence le tableau(t) dans la boucle dico
je ne vois aucune raison de le recopier dans un tableau(r)
il suffit simplement de redimensionner [R1]a II lignes et 3 colonnes
VB: 
Sub tabloSomm()     'mapomme
Dim t, dico As New Dictionary, i&, clef, ii&, j&, Ti

   Ti = Timer
   t = Range("a1").CurrentRegion
   Set dico = CreateObject("scripting.dictionary")
   dico.CompareMode = TextCompare
   For i = 2 To UBound(t)
      clef = Join(Array(t(i, 2), t(i, 3)), "|")
      If Not dico.Exists(clef) Then
         ii = dico.Count + 1
         dico(clef) = ii
         t(ii, 1) = t(i, 2): t(ii, 2) = t(i, 3): t(ii, 3) = t(i, 16)
      Else
         ii = dico(clef)
         t(ii, 3) = t(ii, 3) + t(i, 16)
      End If
   Next i
   'ReDim r(1 To dico.Count, 1 To 3)
   'For i = 2 To dico.Count + 1
      'For j = 1 To 3
         'r(i - 1, j) = t(i - 1, j)
      'Next j
   'Next i
   With Range("r1")
      .CurrentRegion.ClearContents: .Resize(ii, 3) = t: .CurrentRegion.Borders.LineStyle = xlContinuous
   End With
   MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub
;)
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous, @patricktoulon :)

patricktoulon à dit:
a partir du moment ou on réagence le tableau(t) dans la boucle dico
je ne vois aucune raison de le recopier dans un tableau(r)
Cliquez pour agrandir...

Tout simplement pour répondre à la question du demandeur @cp4 que je salue (l'affichage sur une feuille de calcul n'est pas demandé mais ça fait plus joli). ;)

Je rappelle la question :
cp4 à dit:
Maintenant, je voudrais repasser vers un autre tableau pour séparer les noms, prénoms et le montants.
Cliquez pour agrandir...
ou encore:
cp4 à dit:
je voudrais construire un tableau (array)
Cliquez pour agrandir...
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
RE
bonjour @mapomme
si ça n'est pas dérangeant l'utilisation d'un range tempo comme c'est le cas ici
ben après transfert dans le r1 resize --> t=r1.currentregion.value

voir même pourquoi l'ors des transfert dans t ne pas le faire dans un au tableau
les 2 boucles supplémentaires après serait toujours inutiles
2 tour de 28904 lignes sur 3 colonnes dans cet exemple au moment ou je l'ai essayé c'est pas rien

mais je le redis c'est vraiment pas mal ce coup du dico avec index dans item
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
patricktoulon à dit:
voir même pourquoi l'ors des transfert dans t ne pas le faire dans un au tableau
Cliquez pour agrandir...

La question est d'avoir le résultat dans un array avec le nombre de lignes juste nécessaire. Pour cela, il faudrait déterminer à l'avance le nombre de lignes résultats avant le traitement des lignes de t.
Je n'ai pas encore trouvé de solution élégante en utilisant uniquement les fonctions natives de VBA.
 
Vote positif 0 Vote négatif

Discussions similaires

U
  • Question
Autres [RÉSOLU] Faire afficher ligne sur tout le classeur par double clic et la faire maquer à l’enregistrement
Réponses
11
Affichages
416
un internaute
U
cathodique
  • Résolu(e)
XL 2010 Récupérer certaines d'1 tableau dans 1 autre
2 3
Réponses
35
Affichages
3 K
patricktoulon
patricktoulon
L
  • Question
XL 2016 Calcul à partir d'une date précise ou - à défaut - à partir de la date qui suit immédiatement après
Réponses
4
Affichages
407
Lorenzini
L
W
  • Question
XL 2016 Comptabilisation de prénoms rangés en groupes dans des cellules, avec retours à la ligne
Réponses
14
Affichages
552
Webperegrino
W
C
  • Question
XL 2016 Remplir une plage depuis un tableau/array sans passer par une boucle
Réponses
3
Affichages
832
Cyf
C
M
  • Résolu(e)
XL 2021 calcul : Somme des quantités de chaque produit à fabriquer
Réponses
3
Affichages
475
MinstrelL
M
R
  • Résolu(e)
XL 2013 Limite de filtration via un dictionnaire
2
Réponses
17
Affichages
947
Robidic
R
R
  • Question
Microsoft 365 ListBox / ListView et combobox avec choix de colonnes
2
Réponses
20
Affichages
3 K
RaVenSs
R
A
  • Résolu(e)
XL 2019 Passage de 2013 pro à 2019 pro, Pb avec formule VBA, liens hypertexte
2 3 4
Réponses
54
Affichages
2 K
sylvanu
sylvanu
M
  • Question
XL 2016 VBA - Traitement de données avec valeurs identiques dans un dictionnaire
2
Réponses
28
Affichages
1 K
Mak_tarmak
M

Membres actuellement en ligne

4 membres et 47 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 305
Messages
2 087 084
Membres
103 459
dernier inscrit
Arnocal