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:

	A	B	C
1	Product 1	Product 2	Quantity
2	A	B	30
3	B	A	30
4	C	A	10
5	D	C	5
6	E	D	17
7	F	A	11
8	A	C	10
9	G	D	17
10	E	A	10

<tbody>
</tbody>

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!