Macro - Cut and paste a row if duplicate

[Dileep Chandran]

Hello Everybody,

Can anybody help me with a macro which look up A1:F1000 and cut and
paste and then delete the entire row which is a duplicate?

For instance: If data in A1, B1, C1, D1.....F1 is repeating in A5, B5,
C5, D5....F5, delete the entire row (5th row or 1st row based on the
latest date). Date will be given in the column G.

Thanks in advance

-Dileep

 

[Shaka215]

Dileep,

Glad I can finally help someone with something...There is a program
called "Duplicate Master" that will do this for you. See the hyperlink
below...I'm not sure if you are trying to do this for your own
programming self worth or if your just looking to get this done...The
link below will provide you with the end result if your just looking to
get it done...

http://members.iinet.net.au/~brettdj/DM.php

Let me know if this works out... =)

-Todd

 

[Dileep Chandran]

Sorry, I dont want a program. I just need the code.

 

[Shaka215]

I found this in VB HELP...Maybe you can alter the code to get it to do
what you want...

This example sorts the data in a column of the worksheet specified and
then deletes rows that contain duplicate data.

Sub DeleteColumnDupes(strSheetName As String, strColumnLetter As
String)
Dim strColumnRange As String
Dim rngCurrentCell As Range
Dim rngNextCell As Range

strColumnRange = strColumnLetter & "1"

Worksheets(strSheetName).Range(strColumnRange).Sort _
Key1:=Worksheets(strSheetName).Range(strColumnRange)
Set rngCurrentCell = Worksheets(strSheetName).Range(strColumnRange)
Do While Not IsEmpty(rngCurrentCell)
Set rngNextCell = rngCurrentCell.Offset(1, 0)
If rngNextCell.Value = rngCurrentCell.Value Then
rngCurrentCell.EntireRow.Delete
End If
Set rngCurrentCell = rngNextCell
Loop
End Sub

 

[Dileep Chandran]

Thanks. But I need to check multiple values. ie not only in one column.
I need to check if name, street address, city and state are repeating.
(C2 to F2).
If all the data in columns C2 to F2 are repeating in the range
B2:F1000, I have to cut and paste the data to another sheet based on
the latest date given in Column G. Means, We have to keep the latest
dates data.

Is my question clear?

Thank you for your help.

-Dileep

 

[Mike Fogleman]

This can be done, but my question to you is what if John Smith moved to a
different address? Neither would be pasted to sheet2. It appears you are not
interested in keeping John Smith's data up to date on sheet2, but keeping
track of how long John Smith has lived at his current address. Is this what
you intend?

Mike F

 

[Dileep Chandran]

Nice thought Mike. But I am least concerned about that. Do you have a
suggetion?

Thanks
-Dileep

 

[Mike Fogleman]

I see from your second post that you want to cut and paste the oldest date
to sheet2, leaving the newest on sheet1. First I would sort sheet1 by the
dates in ascending order. Then loop from the bottom up, checking each line
against the others for a match and cut and paste the oldest date to sheet2.
Deleting rows should always be done from the bottom up. Let me create a test
workbook and work on some code for this

Mike F

 

[Mike Fogleman]

What is in column B? You mention it in your range to check but only want to
compare columns C-F for matching data.

Mike F

 

[Mike Fogleman]

OK here it is, ignoring column B. Watch out for line wrap in the news
reader. Will send it again unindented if it is too bad to read.

Sub CutOldestDupe()
Dim LRow As Long, LRow2 As Long, i As Integer, ii As Long
Dim SrcRng As Range, DestRng As Range, c As Range, c2 As Range

LRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
If LRow < 3 Then Exit Sub
Set SrcRng = Worksheets("Sheet1").Range("C2:G" & LRow)
Worksheets("Sheet1").Activate
SrcRng.Sort Key1:=Range("G2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

For i = LRow To 3 Step -1
Set c = Cells(i, 3)
c.Select
For ii = LRow - 1 To 2 Step -1
Set c2 = Cells(ii, 3)
c2.Select
If c = c2 Then
If c.Offset(, 1) = c2.Offset(, 1) Then
If c.Offset(, 2) = c2.Offset(, 2) Then
If c.Offset(, 3) = c2.Offset(, 3) Then
If c.Offset(, 4) > c2.Offset(, 4) Then
LRow2 =
Worksheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row + 1
Set SrcRng = Worksheets("sheet1").Range("C"
& c2.Row & ":G" & c2.Row)
SrcRng.Copy Worksheets("sheet2").Range("C" &
LRow2)
c2.EntireRow.Delete
i = i - 1
LRow = LRow - 1
End If
End If
End If
End If
End If
Next ii
LRow = LRow - 1
Next i
End Sub

Mike F

 

[Mike Fogleman]

Maybe easier to read:

Sub CutOldestDupe()
Dim LRow As Long, LRow2 As Long, i As Integer, ii As Long
Dim SrcRng As Range, DestRng As Range, c As Range, c2 As Range

LRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
If LRow < 3 Then Exit Sub
Set SrcRng = Worksheets("Sheet1").Range("C2:G" & LRow)
Worksheets("Sheet1").Activate
SrcRng.Sort Key1:=Range("G2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom

For i = LRow To 3 Step -1
Set c = Cells(i, 3)
c.Select
For ii = LRow - 1 To 2 Step -1
Set c2 = Cells(ii, 3)
c2.Select
If c = c2 Then
If c.Offset(, 1) = c2.Offset(, 1) Then
If c.Offset(, 2) = c2.Offset(, 2) Then
If c.Offset(, 3) = c2.Offset(, 3) Then
If c.Offset(, 4) > c2.Offset(, 4) Then
LRow2 = Worksheets("Sheet2").Cells(Rows.Count,
"C").End(xlUp).Row + 1
Set SrcRng = Worksheets("sheet1").Range("C" & c2.Row & ":G" &
c2.Row)
SrcRng.Copy Worksheets("sheet2").Range("C" & LRow2)
c2.EntireRow.Delete
i = i - 1
LRow = LRow - 1
End If
End If
End If
End If
End If
Next ii
LRow = LRow - 1
Next i
End Sub


Mike F