VBA Code for eliminating Duplicates with certain rules

boldcode · Apr 19, 2011

Hello,

I am fairly new to VBA and I trying to create code behind a command button in excel that will get rid of duplicates based on some business rules.

Below I explain the situation at hand.

I have the following 3 columns in my dataset (these are the actual names of the columns):

Under Column A the name of the column is: Announcement Number
Under Column B the name of the column is: Issue Date
Under Column C the name of the column is: Certificate Returned to HR (Date)

Example of dataset:

<table style="border-collapse: collapse; width: 522px; height: 240px;" border="0" cellpadding="0" cellspacing="0"> <col style="width: 36pt;" width="48"> <col style="width: 120pt;" width="160"> <col style="width: 56pt;" width="75"> <col style="width: 162pt;" width="216"> <tbody><tr style="height: 15pt;" height="20"> <td class="oa1" style="height: 15pt; width: 36pt;" width="48" height="20">
</td> <td class="oa2" style="width: 120pt;" width="160">

Column A

</td> <td class="oa2" style="width: 56pt;" width="75">

Column B

</td> <td class="oa2" style="width: 162pt;" width="216">

Column C

</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 1

</td> <td class="oa2" style="width: 120pt;" width="160">

Announcement Number

</td> <td class="oa2" style="width: 56pt;" width="75">

Issue Date

</td> <td class="oa2" style="width: 162pt;" width="216">

Certificate Returned to HR (Date)

</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 2

</td> <td class="oa2" style="width: 120pt;" width="160">

1003098SQMP

</td> <td class="oa2" style="width: 56pt;" width="75">
</td> <td class="oa2" style="width: 162pt;" width="216">
</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 3

</td> <td class="oa2" style="width: 120pt;" width="160">

1003098SQMP

</td> <td class="oa3" style="width: 56pt;" width="75">

10/28/2010

</td> <td class="oa3" style="width: 162pt;" width="216">

10/28/2010

</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa4" style="height: 15pt; width: 36pt;" width="48" height="20">

row 4

</td> <td class="oa5" style="width: 120pt;" width="160">

1103001MCMP

</td> <td class="oa4" style="width: 56pt;" width="75">

11/3/2010

</td> <td class="oa4" style="width: 162pt;" width="216">

12/16/2010

</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa4" style="height: 15pt; width: 36pt;" width="48" height="20">

row 5

</td> <td class="oa5" style="width: 120pt;" width="160">

1103001MCMP

</td> <td class="oa4" style="width: 56pt;" width="75">

11/3/2010

</td> <td class="oa5" style="width: 162pt;" width="216">
</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa4" style="height: 15pt; width: 36pt;" width="48" height="20">

row 6

</td> <td class="oa5" style="width: 120pt;" width="160">

1103001MCMP

</td> <td class="oa5" style="width: 56pt;" width="75">
</td> <td class="oa5" style="width: 162pt;" width="216">
</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 7

</td> <td class="oa2" style="width: 120pt;" width="160">

1103002JPMP

</td> <td class="oa2" style="width: 56pt;" width="75">
</td> <td class="oa2" style="width: 162pt;" width="216">
</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 8

</td> <td class="oa2" style="width: 120pt;" width="160">

1103003KSMP

</td> <td class="oa2" style="width: 56pt;" width="75">
</td> <td class="oa2" style="width: 162pt;" width="216">
</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 9

</td> <td class="oa2" style="width: 120pt;" width="160">

1103003KSMP

</td> <td class="oa3" style="width: 56pt;" width="75">

11/8/2010

</td> <td class="oa3" style="width: 162pt;" width="216">

12/8/2010

</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 10

</td> <td class="oa2" style="width: 120pt;" width="160">

1103003KSMP

</td> <td class="oa3" style="width: 56pt;" width="75">

11/8/2010

</td> <td class="oa2" style="width: 162pt;" width="216">
</td> </tr> <tr style="height: 15pt;" height="20"> <td class="oa3" style="height: 15pt; width: 36pt;" width="48" height="20">

row 11

</td> <td class="oa2" style="width: 120pt;" width="160">

1103005MCMP

</td> <td class="oa2" style="width: 56pt;" width="75">
</td> <td class="oa2" style="width: 162pt;" width="216">
</td> </tr> </tbody></table>

 As you can see from the data the Announcement Number at times tends to repeat itself. For example, let’s look at rows 4, 5, 6. These rows all have the same Announcement Number, but might or might not have dates in the appropriate cells under columns B and C.

What I want the VBA code do for the specific Announcement Number (in this case 1103001MCMP) is to keep only the record where BOTH THE Issue Date and Certificate Returned to HR (Date) are GREATER than the other pair of dates with the same Announcement Number. In this case the winner and the record we would keep is row 4 and the other two would be deleted. This part is pretty straight forward but the CATCH is that this is only one scenario.

Next I outline all possible scenarios that I need translated into VBA code behind a command button. One thing before I get into the scenarios, when I import this data into excel I might have 15 rows or 500 rows it just depends on the data extract.

 So below are the 3 business rules:

1. 1. If the Announcement Number is the same, then look at both columns B and C to see which PAIR of dates are greater than the other pair of dates in the other records with same Announcement Number and keep that record with the pair of dates that are greater and delete the rest of the records (IN THE CASE OF ROWS 9 AND 10 THE WINNER WOULD BE ROW 9 and in the case of rows 2 and 3 the winner would be row 2 and in the case of rows 4,5,6 the winner is row 4)

2. 2. If the Announcement Number is the same, but no dates exist for column C then look at the dates in column B and keep the greater of the two and delete the rest of the records

3. 3. If the Announcement Number is not a duplicate then obviously keep the record.

So in the dataset above would be reduced rows 2, 4, 9, 11 and all the other would be deleted.

Thanks in Advance

venkat1926 · Apr 20, 2011

one doubt in your data row no 7 does not have data in columns B and c
so notretained
similarly row 11(eleven) also do not have data in B and C and so should not be included. so there are only three rows copied row no.3(not 2),4 and 9 are to be retained.

open four sheets sheet1,sheet2,sheet3,sheet4

in sheet 1 is the main data
sheet1 data is copied to sheet2 to preserve the data
sheet3 is intermediate sheet ultimately no data is there
sheet4 is where you can see the result.

the main macro is "test" to be run
the second macro "undo" is to undo the result of the macro for rerunning the macro "test"

if there is problem give the code which gives problem and copy error message if any

BEFORE USING THIS MACRO IN YOUR ORIGINAL FILE KEEP SAFELY THE ORIGINAL FILE SOMEWHERE FOR RETRIEVAL IF NECESSARY

Code:

Sub test()
Dim annno As Range, unq As Range, cunq As Range, rfull As Range
Dim j, k, cfind As Range, m As Integer, n As Integer, add As String
Application.ScreenUpdating = False
With Worksheets("sheet1")
Set annno = Range(.Range("A1"), .Range("A1").End(xlDown))
Set unq = .Range("A1").End(xlDown).Offset(5, 0)
Set rfull = .Range("A1").CurrentRegion
annno.AdvancedFilter xlFilterCopy, , unq, True
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))
For Each cunq In unq
 rfull.AutoFilter field:=1, Criteria1:=cunq.Value
 rfull.Offset(1, 0).Resize(rfull.Rows.Count - 1, rfull.Columns.Count).SpecialCells(xlCellTypeVisible).Copy
        With Worksheets("sheet3")
        .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
        If .UsedRange.Rows.Count = 1 Then
        If .UsedRange.Columns("B:B") = "" And .UsedRange.Columns("C:C") = "" Then
        rfull.AutoFilter
        GoTo nextcunq
        End If
        .UsedRange.Copy
        GoTo proceed
        End If
        j = WorksheetFunction.Max(.Columns("B:B"))
        Set cfind = .Columns("B:B").Cells.Find(what:=CDate(j), lookat:=xlWhole)
        If cfind.Offset(0, 1) = WorksheetFunction.Max(.Columns("C:C")) Then
        cfind.EntireRow.Copy
        add = cfind.Address
        GoTo proceed
        Else
        Do
        Set cfind = .Columns("B:B").Cells.FindNext(cfind)
        If cfind Is Nothing Then Exit Do
        If cfind.Address = add Then Exit Do
        If cfind.Offset(0, 1) = WorksheetFunction.Max(.Columns("C:C")) Then
        cfind.EntireRow.Copy
          GoTo proceed
            End If
        Loop
        End If
        End With
proceed:
                With Worksheets("sheet4")
                .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
                
                End With
        Worksheets("sheet3").Cells.Clear
         
         

rfull.AutoFilter
nextcunq:
Next cunq
Range(.Range("A1").End(xlDown).Offset(5, 0), .Cells(Rows.Count, "A")).EntireRow.Delete
.Range("A1").EntireRow.Copy
With Worksheets("sheet4")
.Range("A1").PasteSpecial
.Columns("A:Z").AutoFit
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Code:

Sub undo()
With Worksheets("sheet1")
Range(.Range("A1").End(xlDown).Offset(5, 0), .Cells(Rows.Count, "A")).Cells.Clear
End With
Worksheets("sheet3").Cells.Clear
Worksheets("sheet4").Cells.Clear
End Sub

boldcode · Apr 20, 2011

I appreciate the help. You are right about 3 being retained not 2. Row 7 and Row 11 should be retained though because their Announcement is unique regardless if they don't have dates associated with them. You think you could help me out with that.

boldcode · Apr 20, 2011

I almost forgot do I put your main code behind a command button or where should I place the code?

venkat1926 · Apr 21, 2011

1.where to put your macro

there are many ways. I would prefer

-open vbeditor (alt+F11)
-control+R project window opens left
-all open files there
-goto your file highlight click insert(menu)-module
-copy the macro there.
save the file

now assign this macro to your button.
save the file.

2. regarding "Row 7 and Row 11 should be retained" I shall modify the macro and send it to you later

boldcode · Apr 21, 2011

venkat1926,

Thanks so much for help. I actually found some code through another member that works but I need to modify the code to [FONT=&quot]accommodate my real data set. Here is the code below and following the code is how I want to modify it but don't know how. The code works perfect but if I could modify it fit my explanation following the code that would be awesome.

[/FONT] [FONT=&quot]Option Explicit[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]Sub DeleteDuplicates()[/FONT]
[FONT=&quot]Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")[/FONT]
[FONT=&quot]Dim icell As Long, lastrow As Long[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]For icell = lastrow To 2 Step -1[/FONT]
[FONT=&quot]Repeat:[/FONT]
[FONT=&quot] If ws1.Range("A" & icell).Offset(-1, 0).Value = ws1.Range("A" & icell).Value Then[/FONT]
[FONT=&quot] If ws1.Range("C" & icell).Offset(-1, 0).Value > ws1.Range("C" & icell).Value Then[/FONT]
[FONT=&quot] ws1.Range("C" & icell).EntireRow.Delete Shift:=xlUp[/FONT]
[FONT=&quot] GoTo Repeat[/FONT]
[FONT=&quot] Else[/FONT]
[FONT=&quot] If ws1.Range("C" & icell).Value < ws1.Range("B" & icell).Offset(-1, 0).Value Then[/FONT]
[FONT=&quot] ws1.Range("C" & icell).EntireRow.Delete Shift:=xlUp[/FONT]
[FONT=&quot] GoTo Repeat[/FONT]
[FONT=&quot] Else[/FONT]
[FONT=&quot] ws1.Range("B" & icell).Offset(-1, 0).EntireRow.Delete Shift:=xlUp[/FONT]
[FONT=&quot] GoTo Repeat[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot] End If[/FONT]
[FONT=&quot]Next icell[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]End Sub[/FONT]

[FONT=&quot]

[/FONT]how I could get this code to work if the columns in the example where not in that order but were in this order and in between other columns like so:

Under Column A the name of the column is: Region
Under Column B the name of the column is: State
Under Column C the name of the column is: Announcement Number
Under Column D the name of the column is: PayPlan
Under Column E the name of the column is: Issue Date
Under Column F the name of the column is: Level
Under Column G the name of the column is: Certificate Returned to HR (Date)
Under Column H the name of the column is: Cert Number

When I tried the code in this order and it did not work and I am sure its a quick fix

Thank you so much,

venkat1926 · Apr 21, 2011

modifying another persons code I find it very difficult because I have to be in sync with her line of thought. anyhow I shall try. By the by did you find problem in trying to run my macro. let me know.

boldcode · Apr 21, 2011

Your macro runs just fine no problem implementing, I think you did a great job. The only caveat is in regards to "Row 7 and Row 11 not being retained and if everything can happen in sheet1 instead of multiple sheets.

venkat1926 · Apr 21, 2011

the macro test is modified check whether it gives correct results. no change in "undo"

Code:

Sub test()
Dim annno As Range, unq As Range, cunq As Range, rfull As Range
Dim j, k, cfind As Range, m As Integer, n As Integer, add As String
Application.ScreenUpdating = False
With Worksheets("sheet1")
Set annno = Range(.Range("A1"), .Range("A1").End(xlDown))
Set unq = .Range("A1").End(xlDown).Offset(5, 0)
Set rfull = .Range("A1").CurrentRegion
annno.AdvancedFilter xlFilterCopy, , unq, True
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))
For Each cunq In unq
 rfull.AutoFilter field:=1, Criteria1:=cunq.Value
 rfull.Offset(1, 0).Resize(rfull.Rows.Count - 1, rfull.Columns.Count).SpecialCells(xlCellTypeVisible).Copy
        With Worksheets("sheet3")
        .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
        If .UsedRange.Rows.Count = 1 Then
        If .UsedRange.Columns("B:B") = "" And .UsedRange.Columns("C:C") = "" Then
'        rfull.AutoFilter
'        GoTo nextcunq
        .UsedRange.Copy
        GoTo proceed
        End If
        .UsedRange.Copy
        GoTo proceed
        End If
        j = WorksheetFunction.Max(.Columns("B:B"))
        Set cfind = .Columns("B:B").Cells.Find(what:=CDate(j), lookat:=xlWhole)
        If cfind.Offset(0, 1) = WorksheetFunction.Max(.Columns("C:C")) Then
        cfind.EntireRow.Copy
        add = cfind.Address
        GoTo proceed
        Else
        Do
        Set cfind = .Columns("B:B").Cells.FindNext(cfind)
        If cfind Is Nothing Then Exit Do
        If cfind.Address = add Then Exit Do
        If cfind.Offset(0, 1) = WorksheetFunction.Max(.Columns("C:C")) Then
        cfind.EntireRow.Copy
          GoTo proceed
            End If
        Loop
        End If
        End With
proceed:
                With Worksheets("sheet4")
                .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
                
                End With
        Worksheets("sheet3").Cells.Clear
         
         

rfull.AutoFilter
nextcunq:
Next cunq
Range(.Range("A1").End(xlDown).Offset(5, 0), .Cells(Rows.Count, "A")).EntireRow.Delete
.Range("A1").EntireRow.Copy
With Worksheets("sheet4")
.Range("A1").PasteSpecial
.Columns("A:Z").AutoFit
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

boldcode · Apr 23, 2011

venkat1926,

It works like a charm!! Thanks for all your help!!!!

ray:

VBA Code for eliminating Duplicates with certain rules

boldcode

Active Member

Excel Facts

venkat1926

Well-known Member

boldcode

Active Member

boldcode

Active Member

venkat1926

Well-known Member

boldcode

Active Member

venkat1926

Well-known Member

boldcode

Active Member

venkat1926

Well-known Member

boldcode

Active Member

Similar threads

Forum statistics

Share this page

VBA Code for eliminating Duplicates with certain rules

Active Member

Excel Facts

Well-known Member

Active Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock