Deleting rows containing duplicate values in certain columns

[chadski778]

I have a spreadsheet that I need cleaning up. I would like a macro that deletes rows when there are duplicate values in colums D and F but keeps the row with the most recent date which is in column K. For rows were D and F are the same the date value in column K will always be unique

See example

Excel Workbook
	A	B	C	D	E	F	G
2
3		FROM
4	col D	col F	col K
5	B10134	234	01/09/2011	Same in D and F but not K - duplicates
6	B10134	234	14/06/2011
7	B101347	234	13/04/2011
8	B110	333	01/06/2011
9	B110	333	01/07/2011
10	B110	333	01/09/2011	Same in D and F but not K - triplicates
11	B1001	110	03/06/2011
12
13		TO
14	col D	col F	col K
15	B10134	234	01/09/2011
16	B101347	234	13/04/2011
17	B110	333	01/09/2011
18	B1001	110	03/06/2011
19
Sheet1

Thanks

 

[Marcelo Branco]

Hi,

Maybe this (assuming data in Sheet1 - you can adjust it)

(try it in a copy of your workbook)

Sub arrangeData()
    'Thread 579600
    Dim dict As Object
    Dim firstRow As Long, lastRow As Long
    Dim arr As Variant, i As Long
    Dim wk As Worksheet
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    Set wk = Sheets("Sheet1") '<--Adjust the sheet name
    
    With wk
        firstRow = 5
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        
        'Transfer column D to array to speed up the processing
        arr = .Range("D" & firstRow, .Cells(lastRow, "D"))
        
        'Create an object dictionary
        'and set the dictionary to case insensitive
        Set dict = CreateObject("Scripting.Dictionary")
        dict.compareMode = vbTextCompare
        
        
        'Loop throug array and add to dictionary
        For i = 1 To UBound(arr, 1)
            'Check if item exists; update item value if applicable
            If dict.Exists(arr(i, 1)) Then
                If dict.Item(arr(i, 1)) < Range("K" & i + firstRow - 1).Value Then _
                    dict.Item(arr(i, 1)) = Range("K" & i + firstRow - 1).Value
            Else
                dict.Add arr(i, 1), Range("K" & i + firstRow - 1)
            End If
        Next i
        
        'Loop backwards from lastRow to firstRow
        'and delete row conditionally
        For i = lastRow To firstRow Step -1
            If Range("K" & i) <> dict.Item(Range("D" & i).Value) Then _
                Range("K" & i).EntireRow.Delete
        Next i
    End With
        
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
End Sub

 

[chadski778]

I've run the macro and noticed that some duplicates still remain and some unique values have been deleted. There are 65 duplicate lines where D and F are the same but 171 lines have been deleted.

 

[Marcelo Branco]

I've run the macro and noticed that some duplicates still remain and some unique values have been deleted. There are 65 duplicate lines where D and F are the same but 171 lines have been deleted.

Hi,

I tested the macro several times with your data sample and it worked ok, but i looked for duplicates considering only column D.

Should the macro consider column F also to identify a duplicate?

M.

 

[MickG]

Try this:-

[COLOR=navy]Sub[/COLOR] MG18Sep42
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Twn [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Q
[COLOR=navy]Dim[/COLOR] K
[COLOR=navy]Dim[/COLOR] oTm
[COLOR=navy]Set[/COLOR] Rng = Range(Range("D1"), Range("D" & 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
        Twn = Dn & Dn.Offset(, 2)
            [COLOR=navy]If[/COLOR] Not .Exists(Twn) [COLOR=navy]Then[/COLOR]
                .Add Twn, Dn
            [COLOR=navy]Else[/COLOR]
                [COLOR=navy]Set[/COLOR] .Item(Twn) = Union(.Item(Twn), Dn)
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Dim[/COLOR] nRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .Keys
    [COLOR=navy]If[/COLOR] .Item(K).Count > 1 [COLOR=navy]Then[/COLOR]
        [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] oTm [COLOR=navy]In[/COLOR] .Item(K)
            [COLOR=navy]If[/COLOR] Not oTm.Offset(, 7) = Application.Max(.Item(K).Offset(, 7)) [COLOR=navy]Then[/COLOR]
                [COLOR=navy]If[/COLOR] nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR]
                     [COLOR=navy]Set[/COLOR] nRng = oTm
                [COLOR=navy]Else[/COLOR]
                     [COLOR=navy]Set[/COLOR] nRng = Union(nRng, oTm)
                [COLOR=navy]End[/COLOR] If
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Next[/COLOR] oTm
    [COLOR=navy]End[/COLOR] If
 [COLOR=navy]Next[/COLOR] K
nRng.EntireRow.Delete
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[chadski778]

For my problem a duplicate row exists when the values in column D AND column F are the same in different rows. For example, row 1 has 1 in col D and 2 in column F. Row 2 has 1 in col D and 2 in Col F. These are now duplicates with respect to those two columns. I want duplicates deleted but I would like to keep the row with the latest date in col K. The dates will be different for the duplicate rows.

 

[Marcelo Branco]

For my problem a duplicate row exists when the values in column D AND column F are the same in different rows. For example, row 1 has 1 in col D and 2 in column F. Row 2 has 1 in col D and 2 in Col F. These are now duplicates with respect to those two columns. I want duplicates deleted but I would like to keep the row with the latest date in col K. The dates will be different for the duplicate rows.

Maybe this new version

Sub arrData()
    Dim myVar As Long, i As Long
    Dim firstRow As Long, lastRow As Long
    Dim rngData As Range, rngDel As Range
    Dim wk As Worksheet
    
    Set wk = Sheets("Sheet1")
    
    With wk
        firstRow = 5
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        Set rngData = Range("D" & firstRow & ":D" & lastRow)
        
        For i = lastRow To firstRow Step -1
        
             myVar = Evaluate("=MAX(IF(" & rngData.Address & "=" & .Range("D" & i).Address _
             & ",IF(" & rngData.Offset(0, 2).Address & "=" & .Range("F" & i).Address _
            & "," & .Range("K" & firstRow & ":K" & lastRow).Address & ")))")
            
            If .Range("K" & i) <> myVar Then
                If rngDel Is Nothing Then
                    Set rngDel = .Range("K" & i)
                Else
                    Set rngDel = Application.Union(rngDel, .Range("K" & i))
                End If
            End If
            
        Next i
        
        If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
    End With
    
End Sub

M.

 

[chadski778]

Thanks that looks good