Bonjour Julien, bonjour le forum,
Si tu oublies le fichier ça complique un peu...
Bonjour juliensav,
Regarde peut-être la réponse que je viens d'envoyer sur cet autre post.
https://www.excel-downloads.com/threads/recopier-une-cellule-grace-a-la-case-a-cocher.107130/
Amicalement Cibleo
Merci, mais ca ne répond pas à ma demande
Sub Tri()
Dim Tablo, TabCol(), Col, Ck, Ci
Dim x As Long, k As Long, y As Long, m As Long, q As Long, j As Long, n As Long
Set Col = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With Sheets("famille-produit")
Tablo = .Range("A2:C" & .Range("A65536").End(xlUp).Row)
For x = 1 To UBound(Tablo)
If Not Col.Exists(Tablo(x, 3)) Then
Col.Add Tablo(x, 3), 1
Else
temp = Col.Item(Tablo(x, 3))
Col.Remove Tablo(x, 3)
Col.Add Tablo(x, 3), temp + 1
End If
Next x
Ck = Col.keys
Ci = Col.items
For k = LBound(Ci) To UBound(Ci)
ReDim Preserve TabCol(1, 1 To k + 1)
TabCol(0, k + 1) = Ck(k)
TabCol(1, k + 1) = Ci(k)
Next
y = 2
j = 2
For m = 1 To UBound(TabCol, 2)
For q = 1 To UBound(Tablo)
If TabCol(0, m) = Tablo(q, 3) Then
.Range("G" & y) = Tablo(q, 1)
.Range("H" & y) = Tablo(q, 2)
For n = 1 To UBound(Tablo)
If Tablo(n, 3) = Tablo(q, 3) Then
If Tablo(n, 2) <> Tablo(q, 2) Then
.Range("I" & j) = Tablo(n, 2)
j = j + 1
End If
End If
Next
y = y + (TabCol(1, m) - 1)
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub
Bonjour tous le monde,
Si j'ai bien compris voici un exemple :
Code:Sub Tri() Dim Tablo, TabCol(), Col, Ck, Ci Dim x As Long, k As Long, y As Long, m As Long, q As Long, j As Long, n As Long Set Col = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False With Sheets("famille-produit") Tablo = .Range("A2:C" & .Range("A65536").End(xlUp).Row) For x = 1 To UBound(Tablo) If Not Col.Exists(Tablo(x, 3)) Then Col.Add Tablo(x, 3), 1 Else temp = Col.Item(Tablo(x, 3)) Col.Remove Tablo(x, 3) Col.Add Tablo(x, 3), temp + 1 End If Next x Ck = Col.keys Ci = Col.items For k = LBound(Ci) To UBound(Ci) ReDim Preserve TabCol(1, 1 To k + 1) TabCol(0, k + 1) = Ck(k) TabCol(1, k + 1) = Ci(k) Next y = 2 j = 2 For m = 1 To UBound(TabCol, 2) For q = 1 To UBound(Tablo) If TabCol(0, m) = Tablo(q, 3) Then .Range("G" & y) = Tablo(q, 1) .Range("H" & y) = Tablo(q, 2) For n = 1 To UBound(Tablo) If Tablo(n, 3) = Tablo(q, 3) Then If Tablo(n, 2) <> Tablo(q, 2) Then .Range("I" & j) = Tablo(n, 2) j = j + 1 End If End If Next y = y + (TabCol(1, m) - 1) End If Next Next End With Application.ScreenUpdating = True End Sub
Je suis resté sur la 1ère feuille (Colonnes G,H,I) c'est plus facile pour vérifier les résultats. Le traitement se fait en 8-9 secondes (~ 65400 lignes)
Tablo correspond à ta plage de A2 à Cxxx (tableau à 3 colonnes)
Col reprend les élements de la colonne C sans doublon (Keys) et le nombre de doublon pour chaque éléments (Items).
Ck est un tableau avec les élements de Col (Keys).
Ci est un tableau avec les élements de Col (Items), nombre de doublon.
TabCol est un tableau regroupant les Ck et Ci.
Mais attention si tu n'es pas sous Excel 2007 tu seras obligé de couper ta base en deux.
Dans l'exemple que tu as mis, il faut supprimer et mettre ailleurs sur la feuille toutes les lignes après celle-ci
ligne 1558 (13581 - 570-2C-ES - Vanity)
Sinon tu dépasses la limite de la feuille => 65536 lignes.
A+