Delete duplicates but Not delete entire row

[soidog]

Hello,


I have searched and tried a lot but can't find the right answer.
Headers in row 7.
Data range= ("A8": last cell in column "Q")
Column "A"= Names
Column "B"= Dates
Code deletes rows with: duplicates in column"A" and oldest dates in column "B".
Code is working fine but it deletes the entire row when it finds a duplicate in column "A".
Question is: How to only delete cells, column "A:Q" and move up data, so there are no rows with empty cells in "Data range"?

Sub Macro2()


Dim i As Long
Dim sht As Worksheet
Dim lastRow As Long
Dim StartCell As Range




Set sht = Worksheets("Sheet1")
Set StartCell = Range("A8")
lastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row


  sht.Range(StartCell, sht.Cells(lastRow, "Q")).Sort Key1:=Range("A8"), Order1:=xlAscending, Key2:=Range("B8") _
    , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom


    For i = Range("A65000").End(xlUp).Row To 8 Step -1
        If Cells(i, 1) = Cells(i + 1, 1) Then Rows(i).EntireRow.Delete
    Next i


End Sub

Any help is much appreciated.
Thanks in advance!

 

[JoeMo]

If your code is working to your satisfaction apart from the entire row deletion, you can try this modification (in red). Untested by me.

Sub Macro2()


Dim i As Long
Dim sht As Worksheet
Dim lastRow As Long
Dim StartCell As Range




Set sht = Worksheets("Sheet1")
Set StartCell = Range("A8")
lastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row


  sht.Range(StartCell, sht.Cells(lastRow, "Q")).Sort Key1:=Range("A8"), Order1:=xlAscending, Key2:=Range("B8") _
    , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom


    For i = Range("A65000").End(xlUp).Row To 8 Step -1
        If Cells(i, 1) = Cells(i + 1, 1) Then Intersect(Rows(i), Columns("A:Q")).Delete shift:=xlUp
    Next i


End Sub

 

[soidog]

Hi Joe,
Thanks a ton!!!
Your solution works!
I am a newbie to VBA and try to learn by trial and error.
Is there any possibility you could explain why these lines do the job?

For i = Range("A65000").End(xlUp).Row To 8 Step -1
        If Cells(i, 1) = Cells(i + 1, 1) Then Intersect(Rows(i), Columns("A:Q")).Delete shift:=xlUp
    Next i

Thanks again.

 

[JoeMo]

Hi Joe,
Thanks a ton!!!
Your solution works!
I am a newbie to VBA and try to learn by trial and error.
Is there any possibility you could explain why these lines do the job?

For i = Range("A65000").End(xlUp).Row To 8 Step -1
        If Cells(i, 1) = Cells(i + 1, 1) Then Intersect(Rows(i), Columns("A:Q")).Delete shift:=xlUp
    Next i

Thanks again.

You are welcome.

The Intersect function finds the region of intersection of row i and columns A through Q, rather than the entire row i. The shift:= xlUp argument ensures the cells beneath the deleted intersection are shifted up.