Group values with same ID - vba

Question

I'd like to concatenate some values with same ID:
ID Value1 Value2 Value3
1 Red
2 Black
3 Blue
1 High
2 Tall
4 left
My final table should be:
ID Value1 Value2 Value3
1 Red High
2 Black Tall
3 Blue
4 left
I tried the piece of code below, it work with a simple exemple but not with my data:
Sub Concatene()
Dim I As Integer, Txt As String
Dim e As Integer, y As Integer
Sheets("ARTICLE").Select
For I = Range("A1").SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
Txt = LCase(Cells(I, 1).Value)
If Txt <> "" Then
'Compare other rows
For e = I - 1 To 1 Step -1
If LCase(Cells(e, 1)) = Txt Then
'There is a duplicate
For y = 2 To Cells(I, 1).SpecialCells(xlCellTypeLastCell).Column
'concatenate
If Cells(I, y) <> "" And Cells(e, y) = "" Then
Cells(e, y) = Cells(I, y)
End If
Next y
'Delete row
Rows(I).Delete
End If
Next e
End If
Next I
End Sub
Some help would be great.
Thank in advance and sorry for my bad english.

Answer 1

This will work no matter the size of the list as long as there are no empty rows. It is also much faster than deleting the rows.
Sub CondenseList()
Dim Data, NewData
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
Dim index As Long, x As Long, y As Long
Data = Sheets("ARTICLE").Range("A1").CurrentRegion.Offset(1).Value
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 1 To UBound(Data, 1)
If Not list.Contains(Data(x, 1)) Then list.Add Data(x, 1)
index = list.LastIndexOf(Data(x, 1)) + 1
For y = 1 To UBound(Data, 2)
If Data(x, y) <> vbNullString Then NewData(index, y) = Data(x, y)
Next
Next
Sheets("ARTICLE").Range("A1").CurrentRegion.Offset(1).Value = NewData
End Sub
Update: Code breakdown
All the values from the Target range are loaded into the Data array
The NewData array is sized to match the Data array
Next unique ID's are added to an ArrayList
The position off the unique ID's in the ArrayList determines the index that values for that unique ID are written to in the NewData array
Final the NewData array overwrites the values in Target range

Answer 2

Try this
Sub Concatene()
Dim row As Long
Dim row2 As Long
Dim lastrow As Long
Dim used As Long
Dim col As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).row
For row = 2 To lastrow
For row2 = 2 To lastrow
If Cells(row, 1) = Cells(row2, 1) And row <> row2 Then
For col = 2 To 4 'Columns with value. Your example said from column 2 to 4.
If Cells(row, col) = "" Then 'Will only write if its empty
Cells(row, col) = Cells(row2, col)
used = 1 'Line is used...
End If
Next col
If used = 1 Then '...So it can be deleted
used = 0
lastrow = Cells(Rows.Count, "A").End(xlUp).row
Rows(row2).Delete
Exit For
End If
End If
Next row2
Next row
End sub