• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 311
  • Last Modified:

Macro to delete duplicate rows in the sheet

Hello

I need to delete duplicate rows in the sheet on the below condition

I have resourcestartdate, resourceenddate and employeeID columns. Now for duplicate employeeids we need to check the dates and keep only the row in datatable which has the most recent resourcestartdate and delete rest of the rows for that employeeid.
 SOS
Please help

TIA
0
ExpertHelp79
Asked:
ExpertHelp79
  • 29
  • 25
  • 5
  • +2
1 Solution
 
SiddharthRoutCommented:
Try this.

I am assuming that the Col A is "employeeID", Col B is "resourcestartdate" and Col C is "resourceenddate"

Sample file attached. Please run the Sub Sample in the module.

Code Used

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim acell As Range, bcell As Range
    Dim oSht As Worksheet
    Dim strSearch As String
    Dim dt As Date
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("A" & Rows.Count).End(xlUp).Row
    
    For i = lastrow To 2 Step -1
        strSearch = oSht.Range("A" & i).Value
        dt = oSht.Range("B" & i).Value
        
        Set acell = oSht.Range("A1:A" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
        If Not acell Is Nothing Then
            Set bcell = acell
            If acell.Offset(, 1).Value > dt Then oSht.Rows(i).Delete Shift:=xlUp
            ExitLoop = False
            Do While ExitLoop = False
                
                Set acell = oSht.Range("A1:A" & lastrow).FindNext(After:=acell)
                
                If Not acell Is Nothing Then
                    On Error Resume Next
                    If acell.Address = bcell.Address Then Exit Do
                    On Error GoTo 0
                    If acell.Offset(, 1).Value > dt Then oSht.Rows(i).Delete Shift:=xlUp
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
End Sub

Open in new window


Sid
Duplicates-Example.xls
0
 
mvs10000Commented:
An alternative approach without resorting to VBA (assumes you are running Excel 2007):
- Select your data
- Data - Sort & Filter - Sort
- Add a level.  First level sort = employeeID (Order = Smallest to Largest).  Second level sort = start date (Order = Newest to Oldest).
- Select data
- Data - Data Tools - Remove Duplicates
- Unselect all columns except for the employeeID - OK

Excel will keep the first row in each duplicate "cluster" and since it's been sorted by date you will have the correct "parent" record (the one with the most recent date).

Please give SiddharthRout first consideration for any point/answer credit.

Regards,

mvs
0
 
ExpertHelp79Author Commented:
Hello Siddharth
It ran good... but i missed one more filter i apologies

I have a col ProjectNumber

I have resourcestartdate, resourceenddate, ProjectNumber and employeeID columns. Now for duplicate employeeids we need to check the project number and dates and keep only the row in datatable which has the most recent Projectnumber and resourcestartdate and delete rest of the rows for that employeeid where the combination of projectnumber and date are not recent. ie if there are two project number for one employee with multiple date entry then it will check the recent date for the combination of employeeid and projectnumber.
0
 [eBook] Windows Nano Server

Download this FREE eBook and learn all you need to get started with Windows Nano Server, including deployment options, remote management
and troubleshooting tips and tricks

 
SiddharthRoutCommented:
Can you upload an example file?

Sid
0
 
ExpertHelp79Author Commented:
This is the final requirement

Combination of Employeeid,Projectnumber,bk   and recent enddate to be kept rest to be deleted.

 Duplicates-Example--2-.xls
0
 
ExpertHelp79Author Commented:
I am writing the logic again

UNIQUE employeeid,ProjectNumber,BK     and resourceenddate is most recent then keep the row and deleterest of thee rows

Sorry Sid i changed the logic.. hope i get help
0
 
krishnakrkcCommented:
Hi,

try this


Kris
Sub kTest()
Dim ka, k(), c As Long, i As Long, n As Long, t()

ka = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 6)

ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))

With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 2 To UBound(ka, 1)
        If Not .exists(ka(i, 4)) Then
            n = n + 1
            For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
            .Add ka(i, 4), Array(n, UBound(ka, 2))
        Else
            t = .Item(ka(i, 4))
            If CDate(ka(i, 6)) > k(t(0), 6) Then k(t(0), 6) = ka(i, 6)
        End If
    Next
End With
If n Then
    With Sheets("Sheet1").Range("a1")
        .CurrentRegion.Resize(, 6).Offset(1).ClearContents
        .Offset(1).Resize(n, UBound(k, 2)).Value = k
    End With
End If
End Sub

Open in new window

0
 
ExpertHelp79Author Commented:
please explain me the below lines as i have to implement the macro in a larger file where

Total Columns is 29
Project number is at col 5
Employeeid at col 19
BK at 21


ka = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 6)

ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))
If Not .exists(ka(i, 4)) Then
.Offset(1).Resize(n, UBound(k, 2)).Value = k

TIA
0
 
ExpertHelp79Author Commented:
combination at col 22
0
 
ExpertHelp79Author Commented:
i modified it accordingly but getting error
Please check

 
Sub kTest()
Dim ka, k(), c As Long, i As Long, n As Long, t()

ka = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 29)

ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))

With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 2 To UBound(ka, 1)
        If Not .exists(ka(i, 22)) Then
            n = n + 1
            For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
            .Add ka(i, 22), Array(n, UBound(ka, 2))
        Else
            t = .Item(ka(i, 22))
            If CDate(ka(i, 29)) > k(t(0), 29) Then k(t(0), 29) = ka(i, 29)
        End If
    Next
End With
If n Then
    With Sheets("Sheet1").Range("a1")
        .CurrentRegion.Resize(, 29).Offset(1).ClearContents
        .Offset(1).Resize(n, UBound(k, 2)).Value = k
    End With
End If
End Sub

Open in new window

0
 
SiddharthRoutCommented:
So you want to keep this

1      100002      99      110000299      1/06/2010      1/13/2010

and delete rest?

Sid
0
 
ExpertHelp79Author Commented:
employeeID       ProjectNumber      BK      Combination      resourcestartdate      resourceenddate Status
1                      100001              0      11000010      1/2/2010                      1/13/2010                Del
1                      100001              0      11000010      1/8/2010                      1/13/2011
1                      100001              0      11000010      1/8/2010                      1/13/2010                Del
1                      100001             99      110000199      1/8/2010                      1/13/2010
1                      100002             99      110000299      1/6/2010                      1/13/2010
1                      100002             99      110000299      1/2/2010                      1/7/2010                  Del
0
 
ExpertHelp79Author Commented:
hey sid please find the status above
0
 
SiddharthRoutCommented:
Try this

Sample Attached.

Sid

Code Used

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim acell As Range, bcell As Range
    Dim oSht As Worksheet
    Dim strSearch As String
    Dim dt As Date
    Dim Pn As Long, bk As Long
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("A" & Rows.Count).End(xlUp).Row
    
    For i = lastrow To 2 Step -1
        strSearch = oSht.Range("A" & i).Value
        dt = oSht.Range("F" & i).Value
        Pn = oSht.Range("B" & i).Value
        bk = oSht.Range("C" & i).Value
        
        Set acell = oSht.Range("A1:A" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
        If Not acell Is Nothing Then
            Set bcell = acell
            If acell.Offset(, 1).Value = Pn And acell.Offset(, 2).Value = bk Then
                If acell.Offset(, 5).Value > dt Then oSht.Rows(i).Delete Shift:=xlUp
            End If
            ExitLoop = False
            Do While ExitLoop = False
                
                Set acell = oSht.Range("A1:A" & lastrow).FindNext(After:=acell)
                
                If Not acell Is Nothing Then
                    On Error Resume Next
                    If acell.Address = bcell.Address Then Exit Do
                    On Error GoTo 0
                    If acell.Offset(, 1).Value = Pn And acell.Offset(, 2).Value = bk Then
                        If acell.Offset(, 5).Value > dt Then oSht.Rows(i).Delete Shift:=xlUp
                    End If
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
End Sub

Open in new window


Duplicates-Example.xls
0
 
ExpertHelp79Author Commented:
The actual file is like this

Total Columns is 29
Project number is at col 5
Employeeid at col 19
BK at 21
combination at col 22

how can i implement the same code
0
 
krishnakrkcCommented:

In which line you get error ? and what's the error ?
0
 
SiddharthRoutCommented:
2 mins. I will amend the code as per that :)

Sid
0
 
krishnakrkcCommented:

As far I can see the code you modified is ok. What's the error and at which line ?
0
 
SiddharthRoutCommented:
resourceenddate  is in which col?

Sid
0
 
ExpertHelp79Author Commented:
resourceenddate AA col ... sorry i missed
0
 
ExpertHelp79Author Commented:
there are around 29000 rows from which it will delete as per condition
0
 
SiddharthRoutCommented:
Try this

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim acell As Range, bcell As Range
    Dim oSht As Worksheet
    Dim strSearch As String, Comb As String
    Dim dt As Date
    Dim Pn As Long, bk As Long
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("S" & Rows.Count).End(xlUp).Row
    
    For i = lastrow To 2 Step -1
        strSearch = oSht.Range("S" & i).Value '<~~ Emp ID
        dt = oSht.Range("AA" & i).Value '<~~ resourceenddate
        Pn = oSht.Range("E" & i).Value '<~~ ProjectNumber
        bk = oSht.Range("U" & i).Value '<~~ BK
        Comb = oSht.Range("V" & i).Value '<~~ combination
        
        Set acell = oSht.Range("S1:S" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
        If Not acell Is Nothing Then
            Set bcell = acell
            If acell.Offset(, -14).Value = Pn And acell.Offset(, 2).Value = bk _
            And acell.Offset(, 3).Value = Comb Then
                If acell.Offset(, 8).Value > dt Then oSht.Rows(i).Delete Shift:=xlUp
            End If
            ExitLoop = False
            Do While ExitLoop = False
                
                Set acell = oSht.Range("A1:A" & lastrow).FindNext(After:=acell)
                
                If Not acell Is Nothing Then
                    On Error Resume Next
                    If acell.Address = bcell.Address Then Exit Do
                    On Error GoTo 0
                    If acell.Offset(, -14).Value = Pn And acell.Offset(, 2).Value = bk _
                    And acell.Offset(, 3).Value = Comb Then
                        If acell.Offset(, 8).Value > dt Then oSht.Rows(i).Delete Shift:=xlUp
                    End If
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
End Sub

Open in new window


Sid
0
 
ExpertHelp79Author Commented:
Error: unable to get the FindNext property of the range class

at
Set acell = oSht.Range("A1:A" & lastrow).FindNext(After:=acell)

acel = 1495207
0
 
krishnakrkcCommented:
Hi,

Try this one.


Kris
Sub kTest()
Dim ka, k(), c As Long, i As Long, n As Long, t()

ka = Sheets("Sheet1").Range("a1").CurrentRegion.Resize(, 29)

Const CombCol       As Long = 22    '<== adjust the column #
Const ResEndDtCol   As Long = 27    '<== adjust the column #

ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))

With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 2 To UBound(ka, 1)
        If Not .exists(ka(i, CombCol)) Then
            n = n + 1
            For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
            .Add ka(i, CombCol), Array(n, UBound(ka, 2))
        Else
            t = .Item(ka(i, CombCol))
            If CDate(ka(i, ResEndDtCol)) > k(t(0), ResEndDtCol) Then
                For c = 1 To UBound(ka, 2)
                    k(t(0), c) = ka(i, c)
                Next
            End If
        End If
    Next
End With
If n Then
    With Sheets("Sheet1").Range("a1")
        .CurrentRegion.Resize(, 29).Offset(1).ClearContents
        .Offset(1).Resize(n, UBound(k, 2)).Value = k
    End With
End If
End Sub

Open in new window

0
 
SiddharthRoutCommented:
Oops a typo

Change

Set acell = oSht.Range("A1:A" & lastrow).FindNext(After:=acell)

to

Set acell = oSht.Range("S1:S" & lastrow).FindNext(After:=acell)

Sid
0
 
ExpertHelp79Author Commented:
Also one more point
combination is concatenation of Employeeid+ projectno+BK
0
 
SiddharthRoutCommented:
That's ok. Did you try the code after the change?

Sid
0
 
ExpertHelp79Author Commented:
trying its taking sometime as there are 29000 rows
0
 
ExpertHelp79Author Commented:
i hope it is taking much time.... :(
0
 
SiddharthRoutCommented:
Once you confirm that it is working then I will tweak it to make it much faster :)

Sid
0
 
ExpertHelp79Author Commented:
i hope it is working as in 5 mins it reduced from 29000 to 27962 the exact number is 3715 rows less
i am not able to acess
0
 
SiddharthRoutCommented:
In the meantime can you upload a copy of that file here so that i can test it?

Sid
0
 
ExpertHelp79Author Commented:
ahh sorry Sid some confidential data cannot share   :(
0
 
SiddharthRoutCommented:
oOk. Once it is working fine, I will give you a much faster version of the above code. :)

Sid
0
 
ExpertHelp79Author Commented:
sure Sid

i am trying again now

krishnakrkc:the code worked very fast but i need to acess one thing
did you implement the logic
UNIQUE employeeid,ProjectNumber,BK     and resourceenddate is most recent then keep the row and delete rest of the rows
as the count of deletion is less
0
 
SiddharthRoutCommented:
If you are starting all over gain then try this code.

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim acell As Range, bcell As Range, delRange As Range
    Dim oSht As Worksheet
    Dim strSearch As String, Comb As String
    Dim dt As Date
    Dim Pn As Long, bk As Long
    Dim startedAt As String, EndedAt As String
    
    startedAt = Str(Now)
    
    Application.ScreenUpdating = False
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("S" & Rows.Count).End(xlUp).Row
    
    For i = lastrow To 2 Step -1
        strSearch = oSht.Range("S" & i).Value '<~~ Emp ID
        dt = oSht.Range("AA" & i).Value '<~~ resourceenddate
        Pn = oSht.Range("E" & i).Value '<~~ ProjectNumber
        bk = oSht.Range("U" & i).Value '<~~ BK
        Comb = oSht.Range("V" & i).Value '<~~ combination
        
        Set acell = oSht.Range("S1:S" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
        If Not acell Is Nothing Then
            Set bcell = acell
            If acell.Offset(, -14).Value = Pn And acell.Offset(, 2).Value = bk _
            And acell.Offset(, 3).Value = Comb Then
                If delange Is Nothing Then
                    Set delRange = oSht.Rows(i)
                Else
                    Set delRange = Union(delRange, oSht.Rows(i))
                End If
                If acell.Offset(, 8).Value > dt Then oSht.Rows(i).Delete shift:=xlUp
            End If
            ExitLoop = False
            Do While ExitLoop = False
                
                Set acell = oSht.Range("S1:S" & lastrow).FindNext(After:=acell)
                
                If Not acell Is Nothing Then
                    On Error Resume Next
                    If acell.Address = bcell.Address Then Exit Do
                    On Error GoTo 0
                    If acell.Offset(, -14).Value = Pn And acell.Offset(, 2).Value = bk _
                    And acell.Offset(, 3).Value = Comb Then
                        If delange Is Nothing Then
                            Set delRange = oSht.Rows(i)
                        Else
                            Set delRange = Union(delRange, oSht.Rows(i))
                        End If
                    End If
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
    
    delRange.Delete shift:=xlUp
    Application.ScreenUpdating = True
    EndedAt = Str(Now)
    
    MsgBox "Process Started at " & startedAt & " and Ended at " & EndedAt
End Sub

Open in new window


Sid
0
 
ExpertHelp79Author Commented:
error at
If delange Is Nothing Then

object required
0
 
SiddharthRoutCommented:
Hmph a typo...

Change delange to

delRange

Sid
0
 
SiddharthRoutCommented:
Do that at Line 51 as well.

Sid
0
 
krishnakrkcCommented:
Hi,

The code takes the unique string from combination column. It'll keep only one record for each combination.

this part of the code

If CDate(ka(i, ResEndDtCol)) > k(t(0), ResEndDtCol) Then

confirms the recent date record.

HTH

0
 
ExpertHelp79Author Commented:
sid my excel is dead its i hope 20 mins now the time span is too much
0
 
SiddharthRoutCommented:
Strange...

Did it work for the sample files above?

Sid
0
 
ExpertHelp79Author Commented:
krishnakrkc: i will update you tomorrow morning about the validity of the macro... also thanks a lot for helping
0
 
ExpertHelp79Author Commented:
Sid .. yes it worked for the sample file but when i am implementing on the real file  with 28000 rows the excel is dead
0
 
SiddharthRoutCommented:
Can you do me a favor... just create a sample of dummy data but leave the Row 1 intact and upload it. let me test it for you.

Sid
0
 
ExpertHelp79Author Commented:
sure
0
 
ExpertHelp79Author Commented:
hello Sid i have created the file .. please play with the Resource Start and End date to satisfy the logic

of the combination of (Employeeid,WbsCode,BillinkKey) + Recent Resource End Date
Book1.xlsx
0
 
SiddharthRoutCommented:
New conditions? (WbsCode,BillinkKey)?

Sid
0
 
SiddharthRoutCommented:
So in the above example only the 11th row will be deleted?

Sid
0
 
ExpertHelp79Author Commented:
ya.. but i will like to see the result for different dates

also again
 (Employeeid,WbsCode,BillingKey) + Recent Resource End Date
wbscode is projectnumber and billingkey is bk
0
 
SiddharthRoutCommented:
Then try this?

Sid

Code Used

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim acell As Range, bcell As Range, delRange As Range
    Dim oSht As Worksheet
    Dim strSearch As String, Comb As String
    Dim dt As Date
    Dim Pn As Long, bk As Long
    Dim startedAt As String, EndedAt As String
    
    startedAt = Str(Now)
    
    Application.ScreenUpdating = False
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("S" & Rows.Count).End(xlUp).Row
    
    For i = lastrow To 2 Step -1
        strSearch = oSht.Range("S" & i).Value '<~~ Emp ID
        dt = oSht.Range("AA" & i).Value '<~~ resourceenddate
        Pn = oSht.Range("E" & i).Value '<~~ ProjectNumber
        bk = oSht.Range("U" & i).Value '<~~ BK
        Comb = oSht.Range("V" & i).Value '<~~ combination
        
        Set acell = oSht.Range("S1:S" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
        If Not acell Is Nothing Then
            Set bcell = acell
            If acell.Offset(, -14).Value = Pn And acell.Offset(, 2).Value = bk _
            And acell.Offset(, 3).Value = Comb Then
                If acell.Offset(, 8).Value > dt Then
                    If delRange Is Nothing Then
                        Set delRange = oSht.Rows(i)
                    Else
                        Set delRange = Union(delRange, oSht.Rows(i))
                    End If
                End If
            End If
            ExitLoop = False
            Do While ExitLoop = False
                
                Set acell = oSht.Range("S1:S" & lastrow).FindNext(After:=acell)
                
                If Not acell Is Nothing Then
                    On Error Resume Next
                    If acell.Address = bcell.Address Then Exit Do
                    On Error GoTo 0
                    If acell.Offset(, -14).Value = Pn And acell.Offset(, 2).Value = bk _
                    And acell.Offset(, 3).Value = Comb Then
                        If acell.Offset(, 8).Value > dt Then
                            If delRange Is Nothing Then
                                Set delRange = oSht.Rows(i)
                            Else
                                Set delRange = Union(delRange, oSht.Rows(i))
                            End If
                        End If
                    End If
                Else
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
    
    delRange.Delete shift:=xlUp
    Application.ScreenUpdating = True
    EndedAt = Str(Now)
    
    MsgBox "Process Started at " & startedAt & " and Ended at " & EndedAt
End Sub

Open in new window

Duplicates-Example.xls
0
 
ExpertHelp79Author Commented:
the code took 40 minutes to execute and returned the same row as  krishnakrkc: which takes few second. I am still evaluating the result and let you know asap.
But sid can you make this code work as fast
0
 
SiddharthRoutCommented:
The above code that I gave you should not take more than 10 seconds.

Can you post the screenshot of the message box that you get at the end of the code.

Sid
0
 
ExpertHelp79Author Commented:
its already 20 mins running... i will share the result soon
0
 
ExpertHelp79Author Commented:
time
0
 
SiddharthRoutCommented:
Strange....

Let me see if I can use ant other alternative...

Sid
0
 
SiddharthRoutCommented:
Would it matter if I sorted the data first?

Sid
0
 
ExpertHelp79Author Commented:
ahhh i dont know may be it can help... but what is the approach krishnakrkc:  made is doing fast
0
 
SiddharthRoutCommented:
How much time does this take?

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim acell As Range, bcell As Range, delRange As Range
    Dim oSht As Worksheet
    Dim strSearch As String, Comb As String
    Dim dt As Date
    Dim Pn As Long, bk As Long
    Dim startedAt As String, EndedAt As String
    
    startedAt = Str(Now)
    
    Application.ScreenUpdating = False
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("S" & Rows.Count).End(xlUp).Row
    
    oSht.Range("A2:AC" & lastrow).Sort Key1:=oSht.Range("S2"), Key2:=oSht.Range("E2"), _
    Key3:=oSht.Range("U2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    For i = lastrow To 2 Step -1
        If oSht.Range("S" & i).Value = oSht.Range("S" & i - 1).Value Then
            If oSht.Range("E" & i).Value = oSht.Range("E" & i - 1).Value Then
                If oSht.Range("U" & i).Value = oSht.Range("U" & i - 1).Value Then
                    If oSht.Range("V" & i).Value = oSht.Range("V" & i - 1).Value Then
                        If oSht.Range("AA" & i - 1).Value > oSht.Range("AA" & i).Value Then
                            If delRange Is Nothing Then
                                Set delRange = oSht.Rows(i)
                            Else
                                Set delRange = Union(delRange, oSht.Rows(i))
                            End If
                        Else
                            If delRange Is Nothing Then
                                Set delRange = oSht.Rows(i - 1)
                            Else
                                Set delRange = Union(delRange, oSht.Rows(i - 1))
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next i
    delRange.Delete shift:=xlUp
    Application.ScreenUpdating = True
    EndedAt = Str(Now)
    
    MsgBox "Process Started at " & startedAt & " and Ended at " & EndedAt
End Sub

Open in new window


Sid
0
 
SiddharthRoutCommented:
Try this.

Cleant it up more...

Sub Sample()
    Dim i As Long, lastrow As Long
    Dim delRange As Range
    Dim oSht As Worksheet
    Dim startedAt As String, EndedAt As String
    
    startedAt = Str(Now)
    
    Application.ScreenUpdating = False
    
    Set oSht = Sheets("Sheet1")
    
    lastrow = oSht.Range("S" & Rows.Count).End(xlUp).Row
    
    oSht.Range("A2:AC" & lastrow).Sort Key1:=oSht.Range("S2"), Key2:=oSht.Range("E2"), _
    Key3:=oSht.Range("U2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    For i = lastrow To 2 Step -1
        If oSht.Range("S" & i).Value = oSht.Range("S" & i - 1).Value Then
            If oSht.Range("E" & i).Value = oSht.Range("E" & i - 1).Value Then
                If oSht.Range("U" & i).Value = oSht.Range("U" & i - 1).Value Then
                    If oSht.Range("V" & i).Value = oSht.Range("V" & i - 1).Value Then
                        If oSht.Range("AA" & i - 1).Value > oSht.Range("AA" & i).Value Then
                            If delRange Is Nothing Then
                                Set delRange = oSht.Rows(i)
                            Else
                                Set delRange = Union(delRange, oSht.Rows(i))
                            End If
                        Else
                            If delRange Is Nothing Then
                                Set delRange = oSht.Rows(i - 1)
                            Else
                                Set delRange = Union(delRange, oSht.Rows(i - 1))
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next i
    delRange.Delete shift:=xlUp
    Application.ScreenUpdating = True
    EndedAt = Str(Now)
    
    MsgBox "Process Started at " & startedAt & " and Ended at " & EndedAt
End Sub

Open in new window


Sid
0
 
TracyVBA DeveloperCommented:
This question has been classified as abandoned and is being closed as part of the Cleanup Program. See my comment at the end of the question for more details.
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

  • 29
  • 25
  • 5
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now