Macro to remove non-duplicates

[MrMatt]

Hi

I have a Conditional Filter on Columns A and C to highlight duplicates.

What I'm trying to achieve is a macro that finds the non-duplicates in Column C (e.g. Luke) and then deletes that value and all subsequent values to the right, shifting the cells below up.

Actual:
[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]1[/TD]
[TD]James[/TD]
[TD]abc[/TD]
[TD]123[/TD]
[/TR]
[TR]
[TD]Bill[/TD]
[TD]8[/TD]
[TD]Luke[/TD]
[TD]def[/TD]
[TD]456[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]3[/TD]
[TD]Bill[/TD]
[TD]ghi[/TD]
[TD]789[/TD]
[/TR]
[TR]
[TD]Art[/TD]
[TD]4[/TD]
[TD]Ted[/TD]
[TD]jkl[/TD]
[TD]012[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]7[/TD]
[TD]Art[/TD]
[TD]mno[/TD]
[TD]345[/TD]
[/TR]
[TR]
[TD]etc.[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Desired:
[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]James[/TD]
[TD]1[/TD]
[TD]James[/TD]
[TD]abc[/TD]
[TD]123[/TD]
[/TR]
[TR]
[TD]Bill[/TD]
[TD]8[/TD]
[TD]Bill[/TD]
[TD]ghi[/TD]
[TD]789[/TD]
[/TR]
[TR]
[TD]Ted[/TD]
[TD]3[/TD]
[TD]Ted[/TD]
[TD]jkl[/TD]
[TD]012[/TD]
[/TR]
[TR]
[TD]Art[/TD]
[TD]4[/TD]
[TD]Art[/TD]
[TD]mno[/TD]
[TD]345[/TD]
[/TR]
[TR]
[TD]Mike[/TD]
[TD]7[/TD]
[TD]Mike[/TD]
[TD]pqr[/TD]
[TD]678[/TD]
[/TR]
</tbody>[/TABLE]

Any suggestions on how to achieve this would be much appreciated.

Many Thanks

Matt

 

[MrMatt]

Assuming the data has headings, and column F available to use as a helper, try this in a copy of your workbook.

Sub rDeleteNonDupes()
  Dim rDel As Range
  
  Application.ScreenUpdating = False
  Range("F2").Formula = "=COUNTIF(A:A,C2)=0"
  With Range("C1", Range("E" & Rows.Count).End(xlUp))
    .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("F1:F2"), Unique:=False
    On Error Resume Next
    Set rDel = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible)
    ActiveSheet.ShowAllData
    On Error GoTo 0
  End With
  If Not rDel Is Nothing Then
    rDel.Delete Shift:=xlUp
  End If
  Range("F2").ClearContents
  Application.ScreenUpdating = True
End Sub

Thanks Peter, your solution works. Having run the macro step by step, it's an elegant solution

 

[MrMatt]

Thanks Jeffrey, it works much better with For Each cll in Range. Rather than calculating the last row I just put in a high value row that I know is blank ("C2:C500") and it works well on some test data. I'll test it with my real data shortly and update you.

Thanks again.

Matt

Jeffrey, it works well with my real data. Thanks again, Matt

 

[Jeffrey20]

You're welcome, glad I was able to help.

 

[Peter_SSs]

Thanks Peter, your solution works. Having run the macro step by step, it's an elegant solution

Thanks for the feedback. Looks like you have a couple of choices.

 

[Peter_SSs]

Looks like you have a couple of choices.

Actually, I withdraw that until the end of this post.
I should have twigged to the issue straight away but when deleting, it is risky working from top to bottom as with Jeffrey's code. If you happen to have consecutive rows to delete, the second one will be missed.
Test Jeffrey's code on this sample data. Both sets of coloured cells should be deleted, but only the green ones are.

Excel Workbook
	A	B	C	D	E
1	A	B	C	D	E
2	James	1	James	abc	123
3	Bill	8	Luke	def	456
4	Ted	3	Tom	xyz	999
5	Art	4	Bill	ghi	789
6	Mike	7	Ted	jkl	12
7			Art	mno	345
8			Mike	pqr	678
Sample

If you want to use a similar looping method, you should start from the bottom and work upwards.
Here's an alternative suggestion doing that.

Sub DeleteByLooping()
  Dim lr As Long, r As Long, x As Long
  
  Application.ScreenUpdating = False
  lr = Range("C" & Rows.Count).End(xlUp).Row
  For r = lr To 2 Step -1
    x = WorksheetFunction.CountIf(Range("A:A"), Cells(r, "C"))
    If x = 0 Then
      Cells(r, "C").Resize(, 3).Delete Shift:=xlUp
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

 

[Jeffrey20]

Peter is right, sorry, I seem to always forget to start from the bottom when deleting things...

This is my version working correctly (from bottom to top), and using "C2:C500" as range.

Sub Macro2()

Dim x As Long
Dim i As Long

For i = 500 To 2 Step -1
x = Application.WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), Range("C" & i))
If x = 0 Then
Range("C" & i & ":E" & i).Delete Shift:=xlUp
End If
Next i

End Sub

Or this one (also working correctly), for range "C2:C###" where ### is the last cell in "C" and it's determined by the code itself.

Sub Macro3()

Dim x As Long
Dim i As Long
Dim LastCell As Long

LastCell = Cells(Rows.Count, 3).End(xlUp).Row

For i = LastCell To 2 Step -1
x = Application.WorksheetFunction.CountIf(ActiveSheet.Range("A:A"), Range("C" & i))
If x = 0 Then
Range("C" & i & ":E" & i).Delete Shift:=xlUp
End If
Next i

End Sub

Thanks to Peter for the reminder.