tri de références par quantités

Salut,

Colles et testes ce code dans un module standard:

Sub Princ()
Dim I&, PLage As Range, T, Temp, Tablo()
Set PLage = Range([B2], [C65536].End(xlUp)) ' à adapter
T = RecupDoublons(PLage.Value, 1)
If IsArray(T) Then
ReDim Tablo(1 To UBound(T) + 1, 1 To 3)
For I = LBound(T) To UBound(T)
Temp = InverseTab(Equiv2(T(I), PLage.Value, 1))
Tablo(I + 1, 1) = T(I)
Tablo(I + 1, 2) = UBound(Temp) + 1 'Nbre de réfs
Tablo(I + 1, 3) = Somme(Temp, 1)
Next I
[C2].Resize(UBound(Tablo), UBound(Tablo, 2)) = Tablo 'à adapter
End If
End Sub

Function RecupDoublons(T, ColT As Byte) 'Zon
Dim I&, J&, Tablo As New Collection, Temp()
For I = LBound(T, 1) To UBound(T, 1)
On Error Resume Next
Tablo.Add T(I, ColT), CStr(T(I, ColT))
If Err = 0 Then
ReDim Preserve Temp(J)
Temp(J) = T(I, ColT)
J = J + 1
End If
Next I
RecupDoublons = Temp
End Function

Function Equiv2(ByVal RechS$, T, Col1 As Byte) 'Zon
Dim I&, J&, K&, Tablo, Temp()
For I = LBound(T) To UBound(T)
If T(I, Col1) = RechS Then
ReDim Preserve Temp(UBound(T, 2) - 1, J)
For K = 0 To UBound(T, 2) - 1
Temp(K, J) = T(I, K + 1)
Next K
J = J + 1
End If
Next I
Equiv2 = Temp
End Function

Function InverseTab(T, Optional Base As Byte = 0) 'Zon
Dim Temp(), I&, J&
ReDim Temp(Base To UBound(T, 2), Base To UBound(T))
For I = LBound(T, 2) To UBound(T, 2)
For J = LBound(T) To UBound(T)
Temp(I, J) = T(J, I)
Next J
Next I
InverseTab = Temp
End Function

Function Somme(T, ColS As Byte) 'Zon
Dim I&
For I = LBound(T) To UBound(T)
Somme = Somme + T(I, ColS)
Next I
End Function

A+++

Re,

J'oubliaais pour le tri par Réf

Rajoutes une ligne et une à modifier:

Sub Princ()
Dim I&, PLage As Range, T, Temp, Tablo()
Set PLage = Range([B2], [C65536].End(xlUp)) ' à adapter
T = RecupDoublons(PLage.Value, 1)
If IsArray(T) Then
ReDim Tablo(1 To UBound(T) + 1, 1 To 3)
For I = LBound(T) To UBound(T)
Temp = InverseTab(Equiv2(T(I), PLage.Value, 1))
Tablo(I + 1, 1) = T(I)
Tablo(I + 1, 2) = UBound(Temp) + 1 'Nbre de réfs
Tablo(I + 1, 3) = Somme(Temp, 1)
Next I
TriMulti Tablo, 1, 1, UBound(Tablo)
[D2].Resize(UBound(Tablo), UBound(Tablo, 2)) = Tablo 'à adapter
End If
End Sub


'Rajouter cette procédure
Sub TriMulti(Tablo, Col As Byte, Min&, Max&) 'ZOn
Dim I&, J&, K&, M, Chaine
I = Min
J = Max
M = Tablo((Min + Max) / 2, Col)
While (I <= J)
While (Tablo(I, Col) < M And I < Max)
I = I + 1
Wend
While (M < Tablo(J, Col) And J > Min)
J = J - 1
Wend
If (I <= J) Then
For K = LBound(Tablo, 2) To UBound(Tablo, 2)
Chaine = Tablo(I, K)
Tablo(I, K) = Tablo(J, K)
Tablo(J, K) = Chaine
Next K
I = I + 1
J = J - 1
End If
Wend
If (Min < J) Then TriMulti Tablo, Col, Min, J
If (I < Max) Then TriMulti Tablo, Col, I, Max
End Sub

A+++

Bonsoir Eric, Zon.

J'étais en train de te préparer un exemple en VBA mais je m'aperçois que Zon m'a devancé.

Je te joins quand même le fichier à toutes fins utiles....

Pour ma part, une seule procédure comme suit :

Private Sub btnTrier_Click()
Dim L As Long, i As Long
Dim TabTemp As Variant
Dim TabTemp2() As Variant
Dim Db As New Collection
Dim Ech1, Ech2
With ActiveSheet
'Mémoriser les données dans un tableau variant temporaire
L = .Range("B65536").End(xlUp).Row
TabTemp = .Range(.Cells(2, 2), .Cells(L, 3)).Value
'Compter le nombre d'occurences (sans doublons)
On Error Resume Next
For L = 1 To UBound(TabTemp, 1)
Db.Add TabTemp(L, 1), CStr(TabTemp(L, 1))
Next L
On Error GoTo 0
'Trier les occurences
For L = 1 To Db.Count - 1
For i = L + 1 To Db.Count
If Db(L) > Db(i) Then
Ech1 = Db(L)
Ech2 = Db(i)
Db.Add Ech1, before:=i
Db.Add Ech2, before:=L
Db.Remove L + 1
Db.Remove i + 1
End If
Next i
Next L
'Mettre à jour les compteurs d'occurences et quantités cumulées
ReDim TabTemp2(1 To Db.Count, 1 To 3)
For L = 1 To Db.Count
TabTemp2(L, 1) = Db.item(L)
For i = 1 To UBound(TabTemp, 1)
If TabTemp(i, 1) = Db.item(L) Then
TabTemp2(L, 2) = TabTemp2(L, 2) + 1
TabTemp2(L, 3) = TabTemp2(L, 3) + TabTemp(i, 2)
End If
Next i
Next L
'Mettre à jour la feuille
.Range(Cells(2, 4), Cells(Db.Count + 1, 6)).Value = TabTemp2
End With
End Sub

Cordialement.
Didier_mDF

merci beaucoup Didier et Zon pour votre aide nocturne
Je teste vos excellentes idées et je me permettrais de vous contacter si j'ai un problème
Bonne journée,
Eric