Delete duplicate rows

    I Have a data like this:


    1/1/2003 123 456 789
    1/1/2003 124 457 790
    2/1/2003 111 444 777
    3/1/2003 112 555 888
    3/1/2003 111 444 777
    3/1/2003 113 333 666
    4/1/2003 110 444 555


    and I want to delete duplicate row except the last row of each date's set
    and the result should be :


    1/1/2003 124 457 790
    2/1/2003 111 444 777
    3/1/2003 113 333 666
    4/1/2003 110 444 555


    How can I code it ?

    try this:


    Sub DleteDups()
    Dim Cell As Range


    Do While ActiveCell.Offset(1, 0) <> ""
    If ActiveCell.Value <> ActiveCell.Offset(1, 0).Value Then
    ActiveCell.Offset(1, 0).Select
    Else
    ActiveCell.EntireRow.Delete
    End If
    Loop
    End Sub

    Just to add some good to this feed I would like to take an opportunity of offering a pre delete VBA routine, one of my personal favorites, this is not my own work and yet is one I started with and have moved on a very long ways, so I post the original I picked up somewhere and hope you enjoy this too,


    The code will sort and colour red and duplicates so you can scroll down and look at your selections and if needed run a second code like what already been post to take care of this deleting side.


    Hope you like it.


    Best possible regards


    Jack in the UK


    Code:


    Sub JackintheUK_Find_Duplicate_Rows()
    ScreenUpdating = False
    FirstItem = ActiveCell.Value
    Offsetcount = 1
    Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("a1").Select
    SecondItem = ActiveCell.Offset(1, 0).Value
    Do While ActiveCell <> ""
    If FirstItem = SecondItem Then
    ActiveCell.Offset(Offsetcount, 0).Interior.Color = RGB(255, 0, 0)
    Offsetcount = Offsetcount + 1
    SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
    Else
    ActiveCell.Offset(Offsetcount, 0).Select
    FirstItem = ActiveCell.Value
    SecondItem = ActiveCell.Offset(1, 0).Value
    Offsetcount = 1
    End If
    Loop
    ScreenUpdating = True
    End Sub

    Hello Jack


    Can I know which lines of VB Code that I need to delete or amend. So that, the macro would not sort the listing accordingly.

    No the code I have offered will sort first, then checking one cell against the cell directly below, and move down one cell and recheck.


    This offering is not really designed for what you ask, and really you need to redesign the script from scratch its not so editable I guess is what im saying.


    What I sometimes do is copy all my sheet to another and test before on my real work, I fine this test useful just in case. These highlights are a useful tool to manually look / check.


    Like my post said no solution to the original post but an alternative to deleting, just an idea I guess


    Hope that explains why I posted as such


    Kindest possible regards


    Jack in the UK

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!

Register Yourself Login