Hello,
ça pourra peut-être t'aider :
Sub TriDbls()
Dim varArrTmp As Variant
Dim objDico As Object
Dim i&
Dim rngData As Range
Dim strConcat$, strKey$
' Tri du tableau sur 3 colonnes ##############
Set rngData = ActiveSheet.Range("A1").CurrentRegion
With ActiveSheet.Sort
With .SortFields
.Clear
.Add Key:=Range("A1:A" & rngData.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending
.Add Key:=Range("B1:B" & rngData.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending
.Add Key:=Range("C1:C" & rngData.Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending
End With
.SetRange rngData
.Header = xlNo
.Apply
End With
Set rngData = Nothing
'#################################
'Ajoute la concatenation de la colonne A & B dans un dictionnaire (ex : X10 11570)
Set objDico = CreateObject("Scripting.Dictionary")
varArrTmp = ActiveSheet.Range("A1").CurrentRegion
For i = LBound(varArrTmp) To UBound(varArrTmp)
objDico(varArrTmp(i, 1) & varArrTmp(i, 2)) = objDico(varArrTmp(i, 1) & varArrTmp(i, 2)) + 1
Next i
'####################################################
' Ici on vient identifier les clefs (col A & col B) en doubles et celles uniques, puis on fait un traitement propre à chacune
ligne = 1: i = LBound(varArrTmp)
ActiveSheet.Columns("E:G").ClearContents
Do Until i > UBound(varArrTmp) ' Boucle de la premiere donnée à la derniere
If objDico(varArrTmp(i, 1) & varArrTmp(i, 2)) > 1 Then ' Si la clef est en double (>1) dans le dico
strKey$ = varArrTmp(i, 1) & varArrTmp(i, 2) ' Garde la clef en mémoire
strConcat$ = vbNullString ' Vide la concatenation de la colonne C (ex : 44b,45a,2ba ...)
' Comme mes données ont été triés précédemment, je sais que les doublons se suivent
' donc je boucle tant que j'ai la même clef et je viens creer ma concatenation du style => 44b,45a,2ba ...
Do While varArrTmp(i, 1) & varArrTmp(i, 2) = strKey$
strConcat$ = strConcat$ & varArrTmp(i, 3) & ","
i = i + 1
If i > UBound(varArrTmp) Then Exit Do
Loop
'Ici j'affiche le resultat dans la feuille
ActiveSheet.Cells(ligne, "e") = varArrTmp(i - 1, 1)
ActiveSheet.Cells(ligne, "f") = varArrTmp(i - 1, 2)
ActiveSheet.Cells(ligne, "g") = strConcat$
Else ' Si la clef est unique, alors on restitue la donnée tel quel
ActiveSheet.Cells(ligne, "e") = varArrTmp(i, 1)
ActiveSheet.Cells(ligne, "f") = varArrTmp(i, 2)
ActiveSheet.Cells(ligne, "g") = varArrTmp(i, 3)
i = i + 1
End If
ligne = ligne + 1
Loop
Set objDico = Nothing
End Sub