用相同的ID分组值

我想连接一些具有相同ID的值：

ID Value1 Value2 Value3 1 Red 2 Black 3 Blue 1 High 2 Tall 4 left 

我的决赛桌应该是：

 ID Value1 Value2 Value3 1 Red High 2 Black Tall 3 Blue 4 left 

我尝试了下面的一段代码，它只是一个简单的例子，但不是与我的数据：

 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 

一些帮助将是伟大的。

预先感谢，对不起我的英文不好。

Answer 1

只要没有空行，这将工作，无论列表的大小。 这也比删除行快得多。

 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 

更新：代码分解

• Target范围内的所有值都被加载到Data数组中
• NewData数组的大小与Data数组相匹配
• 下一个唯一的ID被添加到一个ArrayList
• ArrayList中唯一ID的位置决定了该唯一ID的值将写入NewData数组中的索引
• 最后，NewData数组覆盖目标范围中的值

Answer 2

尝试这个

 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