Macro that clears duplicates

Admin 1
Viewed 39

I have this macro that loops through rows F and G, clearing a range if it finds a duplicate F&G combo.

Right now, if it finds a unique combo (say, F(1) G(2)), it will delete all of those combos.

How can I change this macro to purge every time it clears, so that it is only clearing duplicates directly below the original?

Thanks.

Sub clearDupsA()
    
        Dim lngMyRow As Long
        Dim lngMyCol As Long
        Dim lngLastRow As Long
        Dim objMyUniqueData As Object
        
        Application.ScreenUpdating = False
    
        lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
        
        Set objMyUniqueData = CreateObject("Scripting.Dictionary")
        
        For lngMyRow = 1 To lngLastRow
            If objMyUniqueData.exists(CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7))) = False Then
                objMyUniqueData.Add CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7)), Cells(lngMyRow, 6) & Cells(lngMyRow, 7)
            Else
                Range(Cells(lngMyRow, 6), Cells(lngMyRow, 7)).ClearContents
            End If
        
        Next lngMyRow
        
        Set objMyUniqueData = Nothing
        
    On Error GoTo ErrorHandler
    ErrorHandler:
       
        Exit Sub
    
    End Sub
vba excel
2 Answers

do not use a dictionary. Instead just use a variable that gets replaced when a new combo is found:

Sub clearDupsA()
    
    Dim lngMyRow As Long
    Dim lngMyCol As Long
    Dim lngLastRow As Long
    Dim tempHolder As String
    
    Application.ScreenUpdating = False
    
    With ActiveSheet 'Don't let vba determine the sheet
        lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
        For lngMyRow = 1 To lngLastRow
            If tempHolder <> (CStr(.Cells(lngMyRow, 6) & .Cells(lngMyRow, 7))) Then
                tempHolder = (CStr(.Cells(lngMyRow, 6) & .Cells(lngMyRow, 7)))
            Else
                .Range(.Cells(lngMyRow, 6), .Cells(lngMyRow, 7)).ClearContents
            End If
        
        Next lngMyRow
    
    End With

End Sub
user_48515900

Clear Consecutive Duplicates

enter image description here

Sub clearDupsA()
    
    Const FirstRowAddress As String = "F2:G2"
    Const Delimiter As String = "|!|"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim rg As Range
    Dim rCount As Long
    
    With ws.Range(FirstRowAddress)
        Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Sub ' no data
        rCount = lCell.Row - .Row + 1
        Set rg = .Resize(rCount)
    End With
    
    Dim Data() As Variant: Data = rg.Value
    
    Dim r As Long
    Dim OldString As String
    Dim NewString As String
    
    For r = 1 To rCount
        NewString = CStr(Data(r, 1)) & Delimiter & CStr(Data(r, 2))
        If StrComp(NewString, OldString, vbTextCompare) = 0 Then
            Data(r, 1) = Empty
            Data(r, 2) = Empty
        Else
            OldString = NewString
        End If
    Next r
    
    rg.Value = Data
    
End Sub
user_98140690
Related