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
patricktoulon

patricktoulon

XLDnaute Barbatruc
ben en fait il faudrait passer par redim preserve transposé pour pouvoir redimensionner au nombre de ligne final
puis re transposer

transposer parce que l'on peut seulement redimensionner la dernière dimension avec redim preserve

mais je ne sais pas si ça serait aussi rapide par contre ;) car il y aurait une action de redim a chaque occurrence nouvelle gardée

bon on aurait plus les 2 boucles finales quand même
peut être la différence entre redim preserve et 2 boucle de reconstruction est suffisamment différente pour intérêt
c'est un choix a tester

edit 30 seconde plus tard

suis je bete oui on redim preserve au debut
redim newtab(1 to 3,1 to ubound(t))
on fait le job dans ta boucle dico avec II en inversant lignes/colonnes
et a la fin
redim preserve newtab(1 to 3,II)
newtab=application.transpose(newtab)
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
Gagné!!!!!!!!
je divise encore tes 1.52 par 2 quasiment
VB: 
Sub tabloSomm()     'patricktoulon sur la base de mapomme dans un tableau transposé
    Dim t, dico As New Dictionary, i&, clef, ii&, j&, Ti, VA
    Ti = Timer
    t = Range("a1").CurrentRegion
    ReDim VA(1 To 3, 1 To UBound(t))
    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
            VA(1, ii) = t(i, 2): VA(2, ii) = t(i, 3): VA(3, ii) = t(i, 16)
            '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)
            VA(3, ii) = VA(3, ii) + t(i, 16)
        End If
    Next i
    ReDim Preserve VA(1 To 3, ii)
    VA = Application.Transpose(VA)
    '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
        .CurrentRegion.ClearContents: .Resize(UBound(VA), 3) = VA: .CurrentRegion.Borders.LineStyle = xlContinuous
    End With
    MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
patricktoulon à dit:
pour éviter la limite de colonne
Cliquez pour agrandir...
C'est pourquoi je l'oublie mais il ne faut pas le rejeter d'office (comme je le fais). L'exécution se fait toujours dans un contexte. Si le contexte aboutit à ne jamais dépasser la limite des colonnes (16 384 ?), alors allons-y bravement et gaiment.
C'est un peu comme les algorithmes de tri. Suivant le nombre d'élément, suivant le degré de désordre, suivant la volonté de vouloir un tri stable ou non, une méthode est préférable à une autre.
Soit dit en passant, le tri par Excel semble stable (je ne l'ai jamais pris en défaut sur ce point) mais je n'en ai pas la preuve. j'utilise cette propriété malgré tout.
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
heu ... bizarre je percute a peine maintenant !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
finalement après les 2 premières heures de la journée
je devrais retourner me coucher moi 🤪 🙃 🙃


comment cela se fait il que la limite soit a 16 384 colonnes
et!!!!!!! que mon redim par exemple sur ce coup la me donne 23 238 colonnes sur 3 lignes
tranposée ca fait 23 238 lignes sur 3 colonnes
tu es sur de ton coup pour la limite des 16 384 colonnes?????


parce que mon résultat dit le contraire
capture du résultat
Capture.JPG


ça serait pas plutôt (x lignes sur 16 384 colonnes) ou (16 384 lignes sur x colonnes)??????????
 
Vote positif 0 Vote négatif
laurent950

laurent950

XLDnaute Accro
Bonjour Le Forum,

VB: 
'Option Explicit
' code nécessite que la référence "Microsoft Scripting Runtime" soit activée
Sub essaiLaurent950()
Dim TI As Variant
    TI = Timer
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim temp, temp2() As Variant
Dim d As New Scripting.Dictionary
    Set d = New Dictionary
Dim i As Double
Dim it As Variant

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)
    Else
        d(Tb(i, 2) & "|" & Tb(i, 3)) = d(Tb(i, 2) & "|" & Tb(i, 3)) + Tb(i, 16)
    End If
Next i

temp = d.Keys ' Impossible de redimenssioner temp  / ReDim Preserve temp(LBound(temp, 1) To UBound(temp, 1), 1 To 2)
' Dimension du tableau temp2.
ReDim temp2(LBound(temp, 1) + 1 To UBound(temp, 1) + 1, 1 To 2)
    For i = LBound(temp2, 1) To UBound(temp2, 1)
        temp2(i, 1) = Split(temp(i - 1), "|")(0): temp2(i, 2) = Split(temp(i - 1), "|")(1)
    Next i
[V1].Resize(UBound(temp2, 1), UBound(temp2, 2)) = temp2 '= Oui
[x1].Resize(d.Count) = Application.Transpose(d.Items) ' = OK
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
cdt
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
tu es un peu tout seul là laurent 🤪
- Ensuite je récupère l'objet Keys que je stock dans une variable tableau
* Etrangement cette variable tableau ne peux être redimensionné ?
Cliquez pour agrandir...
tu te pose encore la question depuis le temps ???
tu n'a toujours pas compris comment ça fonctionne une variable tableau ??

sincèrement a quoi ça sert d'utiliser des fonctions string(split et compagnie) alors que l'on peut stocker les valeurs dans leurs colonnes respectives avec tablosom 1 ou 2(@mapomme ou moi )
et ton compteur est faux si tu me dis que tu met moins de temps que nos versions c'est tout bonnement impossible
rien que déjà un split par tour de boucle t'a déjà perdu
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
purrée laurent !!! soit plus attentif
compare ce qui est comparable !!!!!!!!!!!!!!!!!!
  1. tu scan avec le dico sans comparemode contrairement a nous (pour peu qu'il y est un défaut de majuscule ben t'es mort!!!)
  2. tu ne bordures pas les cellules
alors si je fait toutes les actions qui sont faites comme nos versions a mapomme et moi avec le tiens
voici ton code
VB: 
'Option Explicit
' code nécessite que la référence "Microsoft Scripting Runtime" soit activée
Sub essaiLaurent950()
Dim Ti As Variant
    Ti = Timer
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim temp, temp2() As Variant
Dim d As New Scripting.Dictionary
    Set d = New Dictionary
d.CompareMode = TextCompare
   Dim i As Double
Dim it As Variant

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)
    Else
        d(Tb(i, 2) & "|" & Tb(i, 3)) = d(Tb(i, 2) & "|" & Tb(i, 3)) + Tb(i, 16)
    End If
Next i

' Non (Impossible de stocké la Keys en Variable tableau) donc Impossible a découper
'[V1].Resize(d.Count) = Application.Transpose(d.Keys) '= Non
' Oui
temp = d.Keys ' Impossible de redimenssioner temp  / ReDim Preserve temp(LBound(temp, 1) To UBound(temp, 1), 1 To 2)
' Dimension du tableau temp2.
ReDim temp2(LBound(temp, 1) + 1 To UBound(temp, 1) + 1, 1 To 2)
    For i = LBound(temp2, 1) To UBound(temp2, 1)
        temp2(i, 1) = Split(temp(i - 1), "|")(0): temp2(i, 2) = Split(temp(i - 1), "|")(1)
    Next i
[v1].Resize(UBound(temp2, 1), UBound(temp2, 2)) = temp2 '= Oui
[x1].Resize(d.Count) = Application.Transpose(d.Items) ' = OK
[v1].CurrentRegion.Borders.LineStyle = xlContinuous
MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub

demonstration
demo6.gif


comme dans Teken sur ma play one "YOU LOOSE!!!!!! 🤪 🤪

j'ai testé par respect du fait de ton travail mais je savais déjà que tu n’était pas bon sur ce coup là
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
et si j’enlève le compare mode a tous les 3 tu perds encore la partie et c'est moi qui gagne
  1. sans compare mode et sans bordures je gagne
  2. sans compare mode avec bordure @mapomme gagne
  3. avec les deux @mapomme gagne de 0.005 max sur moi
ça veut dire que @mapomme a certainement un procc graphique meilleur que le mien

après quand même les 3 résultats sont satisfaisant quand même

moins de 2 sec pour filtrer les doublons (sur 2 colonnes!!!)et sur 100000 lignes(+cumul dans une colonne!!!)..... faut pas déconner c'est raisonnable
Ce lien n'existe plus
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
tien compare par toi même

celui de @mapomme
VB: 
Option Explicit

Sub tablosomme()     '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 "pour mapomme : " & Format(Timer - Ti, "0.000\ sec.")
End Sub

le tien
VB: 
'Option Explicit
' code nécessite que la référence "Microsoft Scripting Runtime" soit activée
Sub essaiLaurent950()
Dim Ti As Variant
    Ti = Timer
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim temp, temp2() As Variant
Dim d As New Scripting.Dictionary
    Set d = New Dictionary
d.CompareMode = TextCompare
   Dim i As Double
Dim it As Variant

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)
    Else
        d(Tb(i, 2) & "|" & Tb(i, 3)) = d(Tb(i, 2) & "|" & Tb(i, 3)) + Tb(i, 16)
    End If
Next i

' Non (Impossible de stocké la Keys en Variable tableau) donc Impossible a découper
'[V1].Resize(d.Count) = Application.Transpose(d.Keys) '= Non
' Oui
temp = d.Keys ' Impossible de redimenssioner temp  / ReDim Preserve temp(LBound(temp, 1) To UBound(temp, 1), 1 To 2)
' Dimension du tableau temp2.
ReDim temp2(LBound(temp, 1) + 1 To UBound(temp, 1) + 1, 1 To 2)
    For i = LBound(temp2, 1) To UBound(temp2, 1)
        temp2(i, 1) = Split(temp(i - 1), "|")(0): temp2(i, 2) = Split(temp(i - 1), "|")(1)
    Next i
[v1].Resize(UBound(temp2, 1), UBound(temp2, 2)) = temp2 '= Oui
[x1].Resize(d.Count) = Application.Transpose(d.Items) ' = OK
[v1].CurrentRegion.Borders.LineStyle = xlContinuous
MsgBox "pour Laurent950 : " & Format(Timer - Ti, "0.000\ sec.")
End Sub

le mien
VB: 
Sub tabloSomm2()     'patricktoulon sur la base de mapomme dans un tableau transposé
    Dim t, dico As New Dictionary, i&, clef, ii&, j&, Ti, VA
    Ti = Timer
    t = Range("a1").CurrentRegion
    ReDim VA(1 To 3, 1 To UBound(t))
    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: VA(1, ii) = t(i, 2): VA(2, ii) = t(i, 3): VA(3, ii) = t(i, 16)
        Else
            ii = dico(clef): VA(3, ii) = VA(3, ii) + t(i, 16)
        End If
    Next i
    ReDim Preserve VA(1 To 3, ii)
    With Range("r1")
        .CurrentRegion.ClearContents: .Resize(UBound(VA), 3) = Application.Transpose(VA): .CurrentRegion.Borders.LineStyle = xlContinuous
    End With
    MsgBox "pour patricktoulon : " & Format(Timer - Ti, "0.000\ sec.")
End Sub
cp4 a de quoi étudier là ;)
;)
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
bonjour
@mapomme
teste ca une fois et une autre fois en bloquant les ligne erase
VB: 
Sub teststring()
'On Error Resume Next
ReDim Preserve t(1 To 1, 1 To 89599999): m = 89599999
Erase t 'pour libérer la memoire sinon le test suivant va planter
ReDim Preserve t2(1 To 2, 1 To 15956000): m2 = 15956000
Erase t2 'pour libérer la memoire

Err.Clear
MsgBox "maximum d'element pour une dimention de 1/X  : " & m
MsgBox "maximum d'element pour une dimention de 2/X  : " & m2
End Sub

en fait il y a bien une limite mais celle ci dépend aussi de la mémoire alloué déjà utilisée
autrement dit on ne peut pas savoir en fait
 
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
413
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
551
Webperegrino
W
C
  • Question
XL 2016 Remplir une plage depuis un tableau/array sans passer par une boucle
Réponses
3
Affichages
823
Cyf
C
M
  • Résolu(e)
XL 2021 calcul : Somme des quantités de chaque produit à fabriquer
Réponses
3
Affichages
468
MinstrelL
M
R
  • Résolu(e)
XL 2013 Limite de filtration via un dictionnaire
2
Réponses
17
Affichages
937
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

3 membres et 51 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 229
Messages
2 086 423
Membres
103 206
dernier inscrit
diambote