Excel Macro. Remove Non-Duplicate Rows Based on Column - excel

Question

Trying to run a macro in Excel to remove non dupes so dupes can be examined easily.
Step through each cell in column "B", starting at B2 (B1 is header)
During run, if current cell B has a match anywhere in column B - leave it, if it' unique - remove entire row
The code below is executing with inconsistent results.
Looking for some insight
Sub RemoveNonDupes()
Selection.Copy
Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B2:B5000").AdvancedFilter Action:= xlFilterInPlace, CriteriaRange:= Range("B2"), Unique := True
Range("B2:B5000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.showalldata
End Sub

Answer 1

Not the most direct route, but you could have the macro insert between B and C. Then dump a formula in that column that counts.
Something like =countifs(B:B,B:B) That will give you a count of how many times a record shows, then you can set the script to Loop deleting any row where that value is 1.
Something like
Sub Duplicates()
Columns("B:B").Insert Shift:=xlToRight ' inserts a column after b
count = Sheet1.Range("B:B").Cells.SpecialCells(xlCellTypeConstants).count ' counts how many records you have
crange = "C1:C" & count ' this defines the range your formula's go in if your data doesn't start in b1, change the c1 above to match the row your data starts
Sheet1.Range(crange).Formula = "=countifs(B:B,B:B)" ' This applies the same forumla to the range
ct=0
ct2=0 'This section will go cell by cell and delete the entire row if the count value is 1
Do While ct2 < Sheet1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
For ct = 0 To Sheet1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
If Sheet1.Range("C1").Offset(ct, 0).Value > 1 Then
Sheet1.Range("C1").Offset(ct, 0).EntireRow.Delete
End If
Next
ct2 = ct2 + 1
Loop
Sheet1.Columns("B:B").EntireColumn.delete
end sub
Code isn't pretty, but it should do the job.
**Updated code per comments
Sub Duplicates()
Columns("C:C").Insert Shift:=xlToRight ' inserts a column after b
count = Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count ' counts how many records you have
crange = "C1:C" & count ' this defines the range your formula's go in if your data doesn't start in b1, change the c1 above to match the row your data starts
Activesheet.Range(crange).Formula = "=countifs(B:B,B:B)" ' This applies the same forumla to the range
ct=0
ct2=0 'This section will go cell by cell and delete the entire row if the count value is 1
'''''
Do While ct2 < Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
For ct = 0 To Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
If Activesheet.Range("C1").Offset(ct, 0).Value = 1 Then
Activesheet.Range("C1").Offset(ct, 0).EntireRow.Delete
End If
Next
ct2 = ct2 + 1
Loop
ActiveSheet.Columns("C:C").EntireColumn.delete
end sub
You can try that updated code, the part with the Do Loop is what will delete each column, I fixed it to delete any row where the count is 1.
Based on what I understand, your data should be in column B and the counts should be in column C. If that isn't correct, update the formula's to match

Answer 2

Chris, to examine the unique values in a given range of data, I suggest utilizing Excel's Advanced Copy function in a slightly different way:
Range("RangeWithDupes").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("TargetRange"), unique:=True
The operation will provide you a list of unique values from 'RangeWithDupes' located at 'TargetRange'. You can then use the resultant range to manipulate the source data in many ways. Hope this helps.