VBA almost complete just need help refining

boldcode · Apr 20, 2011

Hello,

I am trying to create a macro 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"> <colgroup><col style="width: 36pt;" width="48"> <col style="width: 120pt;" width="160"> <col style="width: 56pt;" width="75"> <col style="width: 162pt;" width="216"> </colgroup><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 4 business rules:

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 3 and in the case of rows 4,5,6 the winner is row 4)

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. If the Announcement Number is the same, and if one row has a date in Column B and nothing in column C and the other row has a date in Column C and nothing in column B then the winner would be the row in which it has a date in Column C and nothing in column B

4. If the Announcement Number is not a duplicate then obviously keep the record regardless if it has blank dates in columns B and C

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

Rows 7 and 11 would be part of the final dataset because the Announcement Number is unique and not a duplicate.

Below is the vba code from a fellow Mr. Excel member in which it almost does what I want but it just needs some modification. [FONT=&quot]If the code could incorporate business rules 3 and 4 that would be great and if macro could just take place on Sheet1 instead of all the other worksheets that would be great also.
[/FONT]

Here are his (fellow Mr. Excel member) instructions:

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

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

[FONT=&quot] End With[/FONT]
[FONT=&quot] Worksheets("sheet3").Cells.Clear[/FONT]

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

Thanks in Advance

VBA almost complete just need help refining

boldcode

Active Member

Excel Facts

Similar threads

Forum statistics

Share this page

VBA almost complete just need help refining

boldcode

Active Member

Excel Facts

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