VBA to keep duplicates

[Bamh1]

Hello,

Typically the intent is to remove duplicates, an option that is now readily available in Excel. However, I want to do the opposite; I want to keep the duplicates, and remove the single occurrences. I've attached images showing an example in which I need to keep the duplicates in Column A together with their corresponding values in Column B. Does anyone have VBA or other solutions for this?

Thank you,

Shawn

 

[Joe4]

It looks like you are only considering column A when determining duplicates.
This code will delete all single occurrences.

Sub DeleteSingles()

    Dim lr As Long
    Dim r As Long
   
    Application.ScreenUpdating = False
   
'   Find last row with data in column A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
   
'   Populate column C with counts of each column A value
    Range("C2:C" & lr).FormulaR1C1 = "=COUNTIF(C[-2],RC[-2])"
    Range("C2:C" & lr).Value = Range("C2:C" & lr).Value
   
'   Loop through all rows backwards
    For r = lr To 2 Step -1
'       Delete row in column C is 1
        If Cells(r, "C") = 1 Then Rows(r).Delete
    Next r
       
'   Delete temporary column C
    Columns("C:C").Delete
   
    Application.ScreenUpdating = True
   
End Sub

 

[dmt32]

Hi,
untested but another way - maybe

Sub RemoveSingles()
    Dim lr                  As Long
    Dim RemoveSingle        As Range
    
    lr = Range("A1").CurrentRegion.Rows.Count
    
    Application.ScreenUpdating = False
    For r = 2 To lr
        If Application.CountIf(Columns(1), Cells(r, 1).Value) = 1 Then
            If RemoveSingle Is Nothing Then
                Set RemoveSingle = Cells(r, 1)
            Else
                Set RemoveSingle = Union(RemoveSingle, Cells(r, 1))
            End If
        End If
    Next r
    
    If Not RemoveSingle Is Nothing Then RemoveSingle.EntireRow.Delete
    
    Application.ScreenUpdating = True
    
End Sub

code assumes sheet is active & unprotected

Dave

 

[Bamh1]

It looks like you are only considering column A when determining duplicates.
This code will delete all single occurrences.

Sub DeleteSingles()

    Dim lr As Long
    Dim r As Long
 
    Application.ScreenUpdating = False
 
'   Find last row with data in column A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
 
'   Populate column C with counts of each column A value
    Range("C2:C" & lr).FormulaR1C1 = "=COUNTIF(C[-2],RC[-2])"
    Range("C2:C" & lr).Value = Range("C2:C" & lr).Value
 
'   Loop through all rows backwards
    For r = lr To 2 Step -1
'       Delete row in column C is 1
        If Cells(r, "C") = 1 Then Rows(r).Delete
    Next r
  
'   Delete temporary column C
    Columns("C:C").Delete
 
    Application.ScreenUpdating = True
 
End Sub

Thank you so much, Joe. It works.
Much appreciated

 

[Joe4]

You are welcome.
Glad we were able to help!

 

[Bamh1]

It looks like you are only considering column A when determining duplicates.
This code will delete all single occurrences.

Sub DeleteSingles()

    Dim lr As Long
    Dim r As Long
 
    Application.ScreenUpdating = False
 
'   Find last row with data in column A
[QUOTE="Joe4, post: 5950981, member: 6721"]
It looks like you are only considering column A when determining duplicates.
This code will delete all single occurrences.
[CODE=vba]Sub DeleteSingles()

    Dim lr As Long
    Dim r As Long
  
    Application.ScreenUpdating = False
  
'   Find last row with data in column A
    lr = Cells(Rows.Count, "A").End(xlUp).Row
  
'   Populate column C with counts of each column A value
    Range("C2:C" & lr).FormulaR1C1 = "=COUNTIF(C[-2],RC[-2])"
    Range("C2:C" & lr).Value = Range("C2:C" & lr).Value
  
'   Loop through all rows backwards
    For r = lr To 2 Step -1
'       Delete row in column C is 1
        If Cells(r, "C") = 1 Then Rows(r).Delete
    Next r
      
'   Delete temporary column C
    Columns("C:C").Delete
  
    Application.ScreenUpdating = True
  
End Sub

Hi,
untested but another way - maybe

Sub RemoveSingles()
    Dim lr                  As Long
    Dim RemoveSingle        As Range
   
    lr = Range("A1").CurrentRegion.Rows.Count
   
    Application.ScreenUpdating = False
    For r = 2 To lr
        If Application.CountIf(Columns(1), Cells(r, 1).Value) = 1 Then
            If RemoveSingle Is Nothing Then
                Set RemoveSingle = Cells(r, 1)
            Else
                Set RemoveSingle = Union(RemoveSingle, Cells(r, 1))
            End If
        End If
    Next r
   
    If Not RemoveSingle Is Nothing Then RemoveSingle.EntireRow.Delete
   
    Application.ScreenUpdating = True
   
End Sub

code assumes sheet is active & unprotected

Dave

I tested it on my sample data. This one works too. Thank you so much
[/QUOTE]

lr = Cells(Rows.Count, "A").End(xlUp).Row

' Populate column C with counts of each column A value
Range("C2:C" & lr).FormulaR1C1 = "=COUNTIF(C[-2],RC[-2])"
Range("C2:C" & lr).Value = Range("C2:C" & lr).Value

' Loop through all rows backwards
For r = lr To 2 Step -1
' Delete row in column C is 1
If Cells(r, "C") = 1 Then Rows(r).Delete
Next r

' Delete temporary column C
Columns("C:C").Delete

Application.ScreenUpdating = True

End Sub[/CODE]