Hello Jele007,
The attached workbook contains the macro below. A button has been added to "Feuil1" to run the macro.
Sub RemoveDuplicates()
Dim Data As Variant
Dim DstRng As Range
Dim Dict As Object
Dim EndRow As Long
Dim Key As Variant
Dim Item As Variant
Dim SrcRng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("Feuil2")
Set DstRng = Wks.Range("A1")
Set Wks = Worksheets("Feuil1")
Set SrcRng = Wks.Range("A1:C1")
EndRow = SrcRng.Parent.Cells(Rows.Count, SrcRng.Column).End(xlUp).Row
If EndRow < SrcRng.Row Then Exit Sub
Set SrcRng = SrcRng.Resize(RowSize:=EndRow - SrcRng.Row + 1)
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
For n = 1 To SrcRng.Rows.Count
Key = Application.Trim(SrcRng.Item(n, 3))
If Key <> "" Then
If Not Dict.Exists(Key) Then
Item = SrcRng.Item(n, 1).Value
Dict.Add Key, Item
Else
Item = Dict(Key) & "," & SrcRng.Item(n, 1)
Dict(Key) = Item
End If
End If
Next n
n = 0
DstRng.Parent.UsedRange.Clear
For Each Key In Dict.Keys
DstRng.Offset(n, 0).Value = Key
Data = Split(Dict(Key), ",")
DstRng.Offset(n, 1).Resize(1, UBound(Data) + 1).Value = Data
n = n + 1
Next Key
End Sub
Bookmarks