Consolidate Duplicate Rows - VBA?

问题

I have a spreadsheet as below: combine duplicates

I can merge the duplicates by using the script here.

However, I have no idea to add the column A to the merged column (K) . Any help appreciated!

Thanks

回答1:

Assuming that row 1 is the header row so actual data starts on row 2, and you want the output to start in cell J2, this code should work for you:

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

回答2:

Can be achieved without.VBA, but admittedly more work for you than copying code!:
Assuming your headers are in Row3.

1. Copy your sheet and work on the copy.
2. In I3 put:
   =IF(COLUMN()<COUNTIF($G:$G,$G3)+8,IF($G3=$G4,INDIRECT("$h"&ROW()+COLUMN()-8),""),"")
3. Copy the formula across (to at least ColumnL but as required, say to ColumnZ) and down to suit.
4. In two adjacent columns (I have assumed M & N) in Row3 put:
   [M] =H3&","&I3&","&J3&","&K3&","&L3 (extended as required)
   [N] =A3&" - "&"("&M3 (replacing M with the Column reference for the column in step 3) and copy both down to suit.
5. Copy ColumnN and Paste Special Values over the top.
6. In ColumnN replace ,, with nothing.
7. In two adjacent columns (I have assumed O & P) in Row3 put:
   [O] =IF(RIGHT(N3,1)=",",LEFT(N3,LEN(N3)-1)&")",N3&")")
   [P] =G2=G3
   and copy these down to suit.
8. Copy entire sheet and Paste Special Values over the top.
9. Filter ColumnP to select TRUE and delete Row4 to the end.
10. Unfilter.
11. Delete all columns but ColumnO and ColumnG.
12. Put Merged in B2.

Note this does not give you the space between M and XL for Tops shown in your question.

来源：https://stackoverflow.com/questions/18134195/consolidate-duplicate-rows-vba