dim d,i,t,j,n, resultat t = tableau Set d = CreateObject("Scripting.Dictionary") For I = 0 To UBound(tableau) if not d.Exists(t(i,0)) then d.add tableau(i,0),i t(i,1) = tableau(i,1) t(i,2) = tableau(i,2) else ou = d(t(i,0)) for j = 1 to ubound(tableau,2) t(ou,j) = cdbl(tableau(ou,j)) + cdbl(tableau(i,j)) next t(i,0) = "" end if next redim resultat(d.count-1,2) n = 0 for i = 0 to ubound(t) if t(i,0) <> "" then for j = 0 to ubound(tableau,2) resultat(n,j) t(i,j) : resultat(n,j) t(i,j) : resultat(n,j) = t(i,j) next n = n + 1 end if next
Idx = 1 For I = 1 To UBound(Tab3) - 1 'additionne les valeurs Val1 0: Val2 0 For J = I To UBound(Tab3) If Tab3(I, 1) = Tab3(J, 1) Then Val1 = Val1 + Tab3(J, 2) Val2 = Val2 + Tab3(J, 3) End If Next 'Remplir le tableau de résultat si la clef n'a pas déjà été copiée If Not IsInTableau(Tab3(I, 1), Tab4) Then Tab4(Idx, 1) = Tab3(I, 1) Tab4(Idx, 2) = Tab3(I, 2) Tab4(Idx, 3) = Tab3(I, 3) Idx = Idx + 1 End If Next 'Vérifie si la clef est déjà copiée Function IsInTableau(Clef As Variant, Tableau As Variant) As Boolean Dim I As Long For I = 1 To UBound(Tableau) If Clef = Tableau(I, 1) Then IsInTableau = True Exit For End If Next End Function
Il ne les additionne pas, mais les mets les uns après les autres...
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questiondim tableau(3,2), resultat(),d,i,toto,n1,n2,a,b Set d = CreateObject("Scripting.Dictionary") For I = 0 To UBound(tableau) if not d.Exists(tableau(i,0)) then d.add tableau(i,0),tableau(i,1) & chr(1) & tableau(i,2) else toto = d.item(tableau(i,0)) n1 clng(split(toto,chr(1))(0)) : n2 clng(split(toto,chr(1))(1)) d.item(tableau(i,0)) = n1 + tableau(i,1) & chr(1) & n2 + tableau(i,2) end if next a d.Keys : b d.items redim resultat(d.count-1,2) For i = 0 To d.Count -1 toto = b(i) n1 clng(split(toto,chr(1))(0)) : n2 clng(split(toto,chr(1))(1)) resultat(i,0) a(I) : resultat(i,1) n1: resultat(i,2) = n2 Next
dim tableau(3,2), resultat(),d,i,toto,n1,n2,a,b
Malheureusement je n'ai pas mon pc de travail avec moi, donc je verrai ça demain :)
Forum > Visual Basic 6
Je confirme que c'est bien du VBScript
dim d,i,t, resultat t = tableau Set d = CreateObject("Scripting.Dictionary") For I = 0 To UBound(tableau) 'a d.Keys : b d.items if not d.Exists(t(i,0)) then d.add tableau(i,0),i t(i,1) = tableau(i,1) t(i,2) = tableau(i,2) else ou = d(t(i,0)) t(ou,1) = cdbl(tableau(ou,1)) + cdbl(tableau(i,1)) t(ou,2) = cdbl(tableau(ou,2)) + cdbl(tableau(i,2)) t(i,0) = "" end if next redim resultat(d.count-1,2) n = 0 for i = 0 to ubound(t) if t(i,0) <> "" then resultat(n,0) t(i,0) : resultat(n,1) t(i,1) : resultat(n,2) = t(i,2) n = n + 1 end if next
for j = 1 to ubound(tableau,2) t(i,j) = tableau(i,j) next
Const ForReading = 1, ForWriting = 2 Dim oFso, f Set oFso = CreateObject("Scripting.FileSystemObject") Set f = oFso.OpenTextFile("C:\Users\Monique\Downloads\Fichier à importer (1).csv", ForReading) ln=-1 cl=0 while Not f.AtEndOfStream '1ère itération pour définir les limites du tableau ln=ln+1 'définition indice lignes Tab=Split(f.ReadLine,";") If cl < UBound(Tab) Then cl = UBound(Tab) Wend f.Close 'MsgBox "indice lignes : " & ln+1 & "indice colonnes :" & cl+1 Dim Tab2() ReDim Tab2(ln,cl) Set f = oFso.OpenTextFile("C:\Users\Monique\Downloads\Fichier à importer (1).csv", ForReading) i=0 while Not f.AtEndOfStream ' 2ème itération pour remplir le tableau Tab2 Tab = Split(f.ReadLine,";") For j = 0 to UBound(Tab) Tab2(i,j) = Tab(j) Next i=i+1 Wend f.Close Dim Tab3() ReDim Tab3(ln-1,cl) For i=1 to UBound(Tab2,1) ' copie tout de tab2 à tab 3 sauf 1ere ligne marche For j=0 to Ubound(Tab2,2)'oui Tab3(i-1,j)=Tab2(i,j)'oui Next Next For i=0 to UBound(Tab3,1) ' on copie dans tab3 les clés dans la première colonne de chaque ligne For j=0 to Ubound(Tab3,2) Tab3(i,0)=Tab3(i,3)+Tab3(i,5)+Tab3(i,6)+Tab3(i,9) Next Next For i=0 to Ubound(Tab3,1) ' on décale tous les mois vers la gauche For j=1 to Ubound(Tab3,2)-20 Tab3(i,j)=Tab3(i,j+20) Next Next Dim fsot, ft Set fsot = CreateObject("Scripting.FileSystemObject") Set ft = fsot.OpenTextFile("C:\Users\Monique\Downloads\lololololololo.txt", 2,true) Set objKeysDictionnary = CreateObject("Scripting.Dictionary") 'Création du dictionnaire contenant les clés objKeysDictionnary.CompareMode = 1 'Mode de comparaison : texte For i=0 to Ubound(Tab3,1) ' Pour chaque occurence du tableau Tab3 If objKeysDictionnary.Exists(Tab3(i,0)) Then objKeysDictionnary.Item(Tab3(i,0)) = objKeysDictionnary.Item(Tab3(i,0)) + Tab3(i,1) 'Si la clé a déjà été trouvée, ajout des valeurs Else objKeysDictionnary.Add Tab3(i,0), Tab3(i,1) 'Sinon ajout de la clé au dictionnaire End If Next i=0 For Each strKey In objKeysDictionnary.Keys 'Pour chaque clé contenue dans le dictionnaire i=i+1 Next Dim Tab4() ReDim Tab4(i-1,13) i=0 For Each strKey In objKeysDictionnary.Keys 'Pour chaque clé contenue dans le dictionnaire Tab4(i,0)=strKey i=i+1 Next For i=0 to Ubound(Tab3,1) For j=0 to Ubound(Tab4,1) If Tab4(j,0)=Tab3(i,0) Then Tab4(j,1)=Tab4(j,1)+Tab3(i,1) Tab4(j,2)=Tab4(j,2)+Tab3(i,2) Tab4(j,3)=Tab4(j,3)+Tab3(i,3) Tab4(j,4)=Tab4(j,4)+Tab3(i,4) Tab4(j,5)=Tab4(j,5)+Tab3(i,5) Tab4(j,6)=Tab4(j,6)+Tab3(i,6) Tab4(j,7)=Tab4(j,7)+Tab3(i,7) Tab4(j,8)=Tab4(j,8)+Tab3(i,8) Tab4(j,9)=Tab4(j,9)+Tab3(i,9) Tab4(j,10)=Tab4(j,10)+Tab3(i,10) Tab4(j,11)=Tab4(j,11)+Tab3(i,11) Tab4(j,12)=Tab4(j,12)+Tab3(i,12) End If Next Next m=0 Redim Preserve Tab4(Ubound(Tab4,1),13) ' pour le bon nombre de colonnes For i=0 to UBound(Tab4,1) ' copie de tab3 dans le fichier et marche For j=0 to UBound(Tab4,2) If m < UBound(Tab4,2) Then ft.write(Tab4(i,j) & " ") m=m+1 Else ft.write(Tab4(i,j) & vbcrlf) m=0 End If Next Next
peux tu m'aider à intégré ton code dedans ? Je t'en serai très reconnaissant
Set objKeysDictionnary = CreateObject("Scripting.Dictionary") 'Création du dictionnaire contenant les clés
Redim Preserve Tab4(Ubound(Tab4,1),13) ' pour le bon nombre de colonnes