Remove Duplicate macro, modify to delete adjacent cell

[Barryj]

The below macro removes duplicates in column A and is working fine, what I need it to do is have it delete the corrosponding cell in column B and then move data up as is happening now.

I know it is this line of code that needs amending but not sure how to do this?


Sheets("Sheet3").Cells(iCtr, 1).Delete xlShiftUp


I don't want to delete the entire row as I have other data in the sheet which would be affected.


Sub Button3_Click()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through.
iListCount = Sheets("Sheet3").Range("A2:A500").Rows.Count
Sheets("Sheet3").Range("A2").Select
' Loop until end of records.
Do Until ActiveCell = ""
' Loop through records.
For iCtr = 1 To iListCount
' Don't compare against yourself.
' To specify a different column, change 1 to the column number.
If ActiveCell.Row <> Sheets("Sheet3").Cells(iCtr, 1).Row Then
' Do comparison of next record.
If ActiveCell.Value = Sheets("Sheet3").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet3").Cells(iCtr, 1).Delete xlShiftUp
' Increment counter to account for deleted row.
iCtr = iCtr + 1
End If
End If
Next iCtr
' Go to next record.
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
MsgBox "Duplicate Entries Have Been Deleted!"
End Sub

Thanks for any assistance

[jonh]

Just copy that line below the existing line and change the 1 to a 2.
or
Sheets("Sheet3").Range("A" & iCtr & ":B" & iCtr).Delete xlShiftUp

[Barryj]

thanks jonh, that works fine.