Remove duplicate rows based on column BUT leave last occurence

[knigget]

Hi all,

I have been searching for days (literally) for a macro to help me.
This workbook is written to on a sometimes daily basis - the new data always goes to the next available row.

Search for duplicate project numbers in column A
If project number is duplicated anywhere in column A then delete all those above the lowest positioned match.

If that is double-dutch, perhaps I should explain. Everytime this workbook is written to, the new data goes to the next available row (next one down).
This workbook is used to log the status of various projects so it has various project numbers being logged to it.
Column A is called 'project no' and it could be that that over time, one project number appears on lines 1,13,47,63,78 (for example). I would like for the project number detailed on lines 1,13,47,63 to be deleted and to be left with line 78 which would be the most recent.

Can you help me?

 

[MickG]

Try these, they should be Ok now !!
Change the commandButtons at top for sub names as required.

Private Sub CommandButton1_Click()
Dim Rng     As Range
Dim Dn       As Range
Dim nRng    As Range
Dim Q       As Variant
Dim K       As Variant
'==Sets Range with data in colum "A"
Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
 
 '== Removes blank rows
 On Error Resume Next
 Rng.SpecialCells(xlCellTypeBlanks).Resize(, Columns.Count).Delete
   On Error GoTo 0
   '== Sets up Scrip dictionary
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
'==Start loop through "Rng"
For Each Dn In Rng
   '==Finds Unique Data
   If Not .Exists(Dn.Value) Then
        'Adds Key (first unique found), Set up "Item" Array first item "Nothing"  second item the First value.
        '==(Key),   "Item"
        .Add Dn.Value, Array(Nothing, Dn)
    Else
        '== Q equals the array above
        Q = .item(Dn.Value)
            '==Q(0) is first item in array
            If Q(0) Is Nothing Then
                '==set first item to second Item
                Set Q(0) = Q(1)
                'second item = dn
                Set Q(1) = Dn
            Else
                'as above but adding more items (addresses) to first item "Q(0)"
                Set Q(0) = Union(Q(0), Q(1))
                Set Q(1) = Dn
            End If
        '=place altered data back in array
        '=
        .item(Dn.Value) = Q
    End If
Next
'= loop through all items in scrip dic
For Each K In .keys
    '==Loop through keys in dictionary to produce the range to delete
    '==NB:- as we are looking only in First item in array "q(0)", the last _
    'item in your range (The one you don't want to remove will be in Q(2) (second item) and will be left.
    If Not .item(K)(0) Is Nothing Then
        If nRng Is Nothing Then
            Set nRng = .item(K)(0)
        Else
            Set nRng = Union(nRng, .item(K)(0))
        End If
    End If
Next K
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
End With
End Sub

Private Sub CommandButton2_Click()
Dim Rng     As Range
Dim Dn      As Range
Dim nRng    As Range
Dim Q       As Variant
Dim K       As Variant
Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
  On Error Resume Next
  Rng.SpecialCells(xlCellTypeBlanks).Resize(, Columns.Count).Delete
    On Error GoTo 0
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Each Dn In Rng
    If Dn <> "" Then
    If Not .Exists(Dn.Value) Then
        .Add Dn.Value, Array(Nothing, Dn)
    Else
        Q = .item(Dn.Value)
            If nRng Is Nothing Then
                Set Q(0) = Q(1)
                Set Q(1) = Dn
                Set nRng = Q(0)
            Else
                Set Q(0) = Q(1)
                Set nRng = Union(nRng, Q(0))
                Set Q(1) = Dn
            End If
        .item(Dn.Value) = Q
    End If
End If
Next
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
End With
End Sub

 

[knigget]

The top one looks special!

Are these two seperate codes to see which one works better for me or do I need to run them both?

(apologies for newbie questions, I am a newb though!)

 

[MickG]

Both codes do the same thing exactly , or should!!
It was really that once I produced the first code I thought it could be shortened, so now you have two, take your pick. Hope they work for you.
Mick

 

[knigget]

Ok ,the randomness seems to have gone..

If I leave A3 (or line 3) empty, it deletes A2 (line 2) which includes my headers.

Any ideas?

 

[MickG]

Try these:-
I'll have shorly filled the forum up with my code updates !!!

Private Sub CommandButton1_Click()
Dim rng     As Range
Dim Dn       As Range
Dim nRng    As Range
Dim Q       As Variant
Dim K       As Variant
Dim DelRng   As Range
'==Sets Range with data in colum "A"
Set rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
 
 '== Removes blank rows
 On Error Resume Next
  Set DelRng = rng.SpecialCells(xlCellTypeBlanks)
        DelRng.EntireRow.Delete
  On Error GoTo 0
   '== Sets up Scrip dictionary
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
'==Start loop through "Rng"
For Each Dn In rng
   '==Finds Unique Data
   If Not .Exists(Dn.Value) Then
        'Adds Key (first unique found), Set up "Item" Array first item "Nothing"  second item the First value.
        '==(Key),   "Item"
        .Add Dn.Value, Array(Nothing, Dn)
    Else
        '== Q equals the array above
        Q = .item(Dn.Value)
            '==Q(0) is first item in array
            If Q(0) Is Nothing Then
                '==set first item to second Item
                Set Q(0) = Q(1)
                'second item = dn
                Set Q(1) = Dn
            Else
                'as above but adding more items (addresses) to first item "Q(0)"
                Set Q(0) = Union(Q(0), Q(1))
                Set Q(1) = Dn
            End If
        '=place altered data back in array
        '=
        .item(Dn.Value) = Q
    End If
Next
'= loop through all items in scrip dic
For Each K In .keys
    '==Loop through keys in dictionary to produce the range to delete
    '==NB:- as we are looking only in First item in array "q(0)", the last _
    'item in your range (The one you don't want to remove will be in Q(2) (second item) and will be left.
    If Not .item(K)(0) Is Nothing Then
        If nRng Is Nothing Then
            Set nRng = .item(K)(0)
        Else
            Set nRng = Union(nRng, .item(K)(0))
        End If
    End If
Next K
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
End With
End Sub

Private Sub CommandButton2_Click()
Dim rng     As Range
Dim Dn      As Range
Dim nRng    As Range
Dim Q       As Variant
Dim K       As Variant
Dim DelRng  As Range
Set rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
  On Error Resume Next
  Set DelRng = rng.SpecialCells(xlCellTypeBlanks)
        DelRng.EntireRow.Delete
  On Error GoTo 0
    
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Each Dn In rng
    If Dn <> "" Then
    If Not .Exists(Dn.Value) Then
        .Add Dn.Value, Array(Nothing, Dn)
    Else
        Q = .item(Dn.Value)
            If nRng Is Nothing Then
                Set Q(0) = Q(1)
                Set Q(1) = Dn
                Set nRng = Q(0)
            Else
                Set Q(0) = Q(1)
                Set nRng = Union(nRng, Q(0))
                Set Q(1) = Dn
            End If
        .item(Dn.Value) = Q
    End If
End If
Next
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
End With
End Sub

Mick

 

[knigget]

Hi Mick

I really do appreciate your help. Even though it's not quite right, I am much nearer the goal than I would have been without your help.

I have uploaded the summary sheet so you can see the information I am trying to sort. The problems that I am having is that if the lines below line 3 are empty, it starts messing around with the headers.

http://www.mediafire.com/?h9ydhlwfwcsy1vl

I had also tried 'bolting' on a 'sort' macro and 'on load' macro so when the sheet is first opened, it runs your 'find duplicates and delete' code, then sorts it numerically from column A. I am not 100% sure but this seems to swap things about a bit (other cells on a line are moved to other lines).

The summary sheet is written to from various other sheets by means of another macro that is within those other sheets - it needs to be automated which is why I have gone about the summary sheet in the way that I have.

Most interested to see what you come up with, perhaps I am going about this the long winded way?

 

[MickG]

I have your file but because you have a "Workbook Open " event, what I'm seeing (I imagine) is the result after the code has run rather than before.
Can you send the file with a before sheet and an after (Macro run) sheet. With the macro disabled or removed.
Mick

 

[MickG]

Another thought, if you intend to run you code from the "Workbook" event you need to refer to the sheet the code need to run on.
Alter the similar line at the top of the code to below.
NB:-I should copy this to make sure you get the dots.

With Sheets("Sheet1")
Set rng = .Range(.Range("A3"), .Range("A" & Rows.Count).End(xlUp))
 End With

Mick

 

[knigget]

Sure thing, link to two files before and after, both with autorun macro disabled..
before: http://www.mediafire.com/?9wbzg29tcmxm582
after: http://www.mediafire.com/?almnf6k9ll5dzaq


I haven't included the 'sort' code with these but was using

'sort rows numerically from A3
Rows("3:65536").Cells(1, 1).Select
    '.Select
    'ActiveWindow.ScrollRow = 1
    Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub

in the order of: 'autorun' code, your 'find and delete dupes' code, 'sort' code.

 

[MickG]

I've run your sheet code in a Button on the sheet and with a Worksheet Open Event.(Code modified for sheet selection as mentioned :-"With sheets ("Sheet1"))
Both return results as per your sheet "After".
Sort code also run OK, append this if required just above the "End Sub" in code.
What results do you get ???
Mick