PDA

View Full Version : Remove Duplicates by Date Range



Alex O
06-12-2012, 02:28 PM
Hello All,
I'm using the code below to search through a range and delete duplicate account numbers for a one month period. Everything works fine. My dataset, however, will soon be changing to include a four year date range. What I'm wondering is, can my code be edited to scan the range by date (the dates are in A:A) and delete duplicates based on account numbers (housed in C:C)? My problem is that many of the same numbers show up month after month. I don't want the code to search the entire range and remove duplicates, but rather month by month. Hopefully this makes sense!


Public Sub DeleteDuplicateRows()
Dim R As Long
Dim N As Long
Dim V As
Variant
Dim Rng As Range
On Error GoTo
EndMacro
Application.ScreenUpdating = False
Application.Calculation =
xlCalculationManual
Set Rng = Application.Intersect(ActiveSheet.UsedRange,
_

ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing
Row: " & Format(Rng.Row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2
Step -1
If R Mod 500 = 0 Then
Application.StatusBar =
"Processing Row: " & Format(R, "#,##0")
End If
V = Rng.Cells(R,
1).Value
If V = vbNullString Then
If
Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1
Then

Rng.Rows(R).EntireRow.Delete
N = N
+ 1
End If
Else
If
Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1
Then

Rng.Rows(R).EntireRow.Delete
N = N
+ 1
End If
End If
Next
R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating =
True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate
Rows Deleted: " & CStr(N)
End Sub

Bob Phillips
06-12-2012, 03:07 PM
What Excel version do you have?

Can you post an example workbook of the new data?

Alex O
06-12-2012, 03:27 PM
I'm not really sure how to insert a snapshot...hopefully one of these works. If not I can email you the sheet.
Thanks

C:\Users\aoconnell.RAUCHMILLIKEN\Documents\EJHTMLe\TempJean.htm
ABC17LIST_DATECLT_IDDEBT_ID_NO184/6/20101011409288031-1194/6/20101011409288031-1204/8/20101010461288058-1214/8/20101011409288059-1224/8/20101011409288060-1234/8/20101011890288061-1244/8/20101010461288062-1254/8/20101011409288063-1264/8/20101010461288064-1274/8/20101010461288065-1284/8/20101010461288066-1294/8/20101010461288066-1304/8/20101010461288067-1314/8/20101010461288068-1324/8/20101010461288069-1334/8/20101010461288070-1344/8/20101010461288071-1354/8/20101010461288072-1364/8/20101010461288073-1374/8/20101011409288074-1384/8/20101011890288075-18394/8/20101011890288077-1404/8/20101010461288078-1414/8/20101011890288080-1424/8/20101010461288081-1

Bob Phillips
06-12-2012, 03:36 PM
Post it to the forum, we allow attachments.

Go Advanced>Manage Attachments

Alex O
06-12-2012, 03:39 PM
Would it help if I sent the sheet from the workbook? I'm not having much luck posting a screenshot!

Alex O
06-12-2012, 03:49 PM
Here's a sample of the data...

Thanks

Bob Phillips
06-12-2012, 04:16 PM
Try this

Sub DeleteData()
Dim rng As Range
Dim lastrow As Long

Application.ScreenUpdating = False

With ActiveSheet

.Columns("G").Insert
.Rows(1).Insert
.Range("G1").Value = "Temp"
.Range("G2").Value = "False"

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("G1").Resize(lastrow)
.Range("G3").Resize(lastrow - 2).Formula = "=SUMPRODUCT(--(MONTH(A3)=MONTH($A$3:A3)),--(C3=$C$3:C3))>1"
rng.AutoFilter field:=1, Criteria1:="=TRUE"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

rng.EntireRow.Delete
End If

.Columns("G").Delete
End With

Application.ScreenUpdating = True
End Sub

Alex O
06-12-2012, 05:56 PM
I'm testing your code - it's just taking a while to run...
Thanks for the assistance! I'll post the outcome as soon as it's finished running.

Alex O
06-13-2012, 06:27 PM
A few minor tweaks and it worked perfectly!
Thanks again for your help