Duplicate multiples over different columns

[tbollo]

Hello,

My data contains three columns:

'Product 1', 'Product 2' and 'Quantity' - Quantity represents the number of times 'Product 1' and 'Product 2' were purchased together:


[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD="align: center"]A[/TD]
[TD="align: center"]B[/TD]
[TD="align: center"]C[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Product 1[/TD]
[TD]Product 2[/TD]
[TD]Quantity[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]30[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]B[/TD]
[TD]A[/TD]
[TD]30[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]C[/TD]
[TD]A[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]D[/TD]
[TD]C[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]6[/TD]
[TD]E[/TD]
[TD]D[/TD]
[TD]17[/TD]
[/TR]
[TR]
[TD]7[/TD]
[TD]F[/TD]
[TD]A[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]8[/TD]
[TD]A[/TD]
[TD]C[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]9[/TD]
[TD]G[/TD]
[TD]D[/TD]
[TD]17[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]E[/TD]
[TD]A[/TD]
[TD]10[/TD]
[/TR]
</tbody>[/TABLE]


In the above, rows 2 and 3 are the same combination of products with the same quantity. I would like to remove one of these duplicates and keep just one in the list.

NB: the duplicate combinations are not necessarily next to each other, as shown by rows 4 and 8.

Any help?

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG17Apr06
[COLOR="Navy"]Dim[/COLOR] cell [COLOR="Navy"]As[/COLOR] Range, Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]With[/COLOR] Range("A2", Cells(Rows.Count, "B").End(xlUp))
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] cell [COLOR="Navy"]In[/COLOR] .Columns(2).Cells
      [COLOR="Navy"]With[/COLOR] cell
        [COLOR="Navy"]If[/COLOR] .Value2 < .Offset(, -1).Value2 [COLOR="Navy"]Then[/COLOR]
          .Cut
          .Offset(, -1).Insert
        [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] cell
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Txt = Dn.Value & Dn.Offset(, 1).Value & Dn.Offset(, 2).Value
        [COLOR="Navy"]If[/COLOR] Not .Exists(Txt) [COLOR="Navy"]Then[/COLOR]
            .Add Txt, Nothing
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Yongle]

another VBA option
- run from sheet containing the data

Sub RemoveDup()
Application.ScreenUpdating = False
    Dim LastRow As Long, ws As Worksheet
    Set ws = ActiveSheet
    On Error Resume Next
    ws.ShowAllData
    LastRow = Range("A1").CurrentRegion.Rows.Count
    Range("D2").Formula = "=COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)+COUNTIFS($A$2:A2,B2,$B$2:B2,A2,$C$2:C2,C2)"
    Range("D2").Copy ws.Range("D2:D" & LastRow)
    Range("A:D").AutoFilter Field:=4, Criteria1:=">1"
    Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Rows.EntireRow.Delete
    ws.ShowAllData
Application.ScreenUpdating = True
End Sub

 

[Yongle]

or without VBA
- same method as VBA solution

add formula to D2 and copy down
=COUNTIFS($A$2:A2,A2,$B$2:B2,B2,$C$2:C2,C2)+COUNTIFS($A$2:A2,B2,$B$2:B2,A2,$C$2:C2,C2)

Filter the data with column D >1
Select & delete those rows

 

[tbollo]

Thanks got it working!