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?

 

[knigget]

I can't remember how I did it, but I got

100001 x x
100002 x
100003 x
100004

when it should have been

100001
100002
100003
100004 x x x x

Basically, the data in the rows shifted to other rows - possibly as it was deleting a duplicate 100004?!

.(Code modified for sheet selection as mentioned :-"With sheets ("Sheet1"))

What do you mean by this? Lol, I have only just seen the post 'another thought'... Do you mean if I am to use

Sub Workbook_Open()

then I need some reference to 'Sheet1'? How would I do this?


Any luck with the empty rows below A3 and it 'sorts'(messes up) the headers problems?

Thanks Mick

 

[MickG]

The code that works for your data in the "Workbook Open" code is below:-
There may be a problem with it , but I have'nt found them.
This code now relates to sheet (1),specifically.
Try it out with your sheet data and various scenarios, and confirm specific errors if found.

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

Regards Mick

 

[knigget]

Hi Mick

I will try your code, but I have to ask you to look at the file below - this is a perfect demonstration of the rows getting mixed up (made my day that I got it to break again, thought I was going mad!).
http://www.mediafire.com/?75rl8wlxbfo6d2k

You will see the x's end up being associated with the wrong project. Once the macro is run.

 

[knigget]

Update - I think it is caused by the 'sort' code at the end. In that last file I linked to, try taking the 'sort' code out of the equation and it seems happy!?

On the last code you posted it works fine, introduce the 'sort' code and the 'x's shift rows...

 

[knigget]

Ok, this seems to work better:

Range("A3:W65536").Select
    Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

than

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

At a guess, because it is more specific to the cells it is sorting?

 

[MickG]

If you placing that in the "Workbook Open " event you will need to tell it what the sheet is, as below:-
This should do the same as your sort code code, place between the Last "End with" and the "End sub".

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

Mick

 

[knigget]

Thanks for all your help Mick, all sorted