CODEWITHSUNDEEP
excelms-office
chrisrth
chrisrth

Reputation: 1212

Excel Macro. Remove Non-Duplicate Rows Based on Column

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

Upvotes: 0

Views: 2134

Answers (2)

DanB
DanB

Reputation: 96

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

Upvotes: 1

RichC
RichC

Reputation: 1

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.

Upvotes: 0

Related Questions