整合重复行 – VBA？

我有一个电子表格如下： 组合重复

我可以在这里使用脚本合并重复。

但是，我不知道将列A添加到合并列（K）。 任何帮助感激！

谢谢

Answer 1

假设第1行是标题行，因此实际数据从第2行开始，并且您希望输出在单元格J2中启动，则此代码应该适用于您：

Sub tgr() Dim cllSKU As Collection Dim SKUCell As Range Dim rngFound As Range Dim arrData(1 To 65000, 1 To 2) As Variant Dim strFirst As String Dim strJoin As String Dim DataIndex As Long Set cllSKU = New Collection With Range("G3", Cells(Rows.Count, "G").End(xlUp)) On Error Resume Next For Each SKUCell In .Cells cllSKU.Add SKUCell.Text, SKUCell.Text If cllSKU.Count > DataIndex Then DataIndex = cllSKU.Count arrData(DataIndex, 1) = SKUCell.Text arrData(DataIndex, 2) = Cells(SKUCell.Row, "A").Text & " - (" Set rngFound = .Find(SKUCell.Text, .Cells(.Cells.Count), xlValues, xlWhole) If Not rngFound Is Nothing Then strFirst = rngFound.Address Do arrData(DataIndex, 2) = arrData(DataIndex, 2) & Cells(rngFound.Row, "H").Text & "," Set rngFound = .Find(SKUCell.Text, rngFound, xlValues, xlWhole) Loop While rngFound.Address <> strFirst End If arrData(DataIndex, 2) = Left(arrData(DataIndex, 2), Len(arrData(DataIndex, 2)) - 1) & ")" End If Next SKUCell On Error GoTo 0 End With If DataIndex > 0 Then Range("J2:K" & Rows.Count).ClearContents Range("J2:K2").Resize(DataIndex).Value = arrData End If Set cllSKU = Nothing Set SKUCell = Nothing Set rngFound = Nothing Erase arrData End Sub 

Answer 2

可以实现不.VBA，但承认比复制代码更多的工作给你！
假设你的头在Row3中。

1. 复制您的工作表并在副本上工作。
2. 在I3中说：
   =IF(COLUMN()<COUNTIF($G:$G,$G3)+8,IF($G3=$G4,INDIRECT("$h"&ROW()+COLUMN()-8),""),"")
3. 复制公式到（至lessColumnL，但根据需要，说ColumnZ），并下来以适应。
4. 在Row3的两个相邻列（我假设M＆N）中，
   [M] =H3&","&I3&","&J3&","&K3&","&L3 (extended as required)
   [N] =A3&" - "&"("&M3 （将Mreplace为步骤3中列的列引用）并复制两者以适合。
5. 复制ColumnN并将特殊值粘贴到顶部。
6. 在ColumnN中replace,,没有任何东西。
7. 在Row3的两个相邻列（我假设O＆P）中，
   [O] =IF(RIGHT(N3,1)=",",LEFT(N3,LEN(N3)-1)&")",N3&")")
   [P] =G2=G3
   并复制这些以适应。
8. 复制整个工作表并将特殊值粘贴到顶部。
9. 过滤ColumnPselectTRUE并删除Row4到最后。
10. 不过滤。
11. 删除除ColumnO和ColumnG以外的所有列。
12. 把Merged在B2。

请注意，这不会给你在问题中显示的M和XL之间Tops的空间。