CODEWITHSUNDEEP
excelvba
user19385316
user19385316

Reputation:

Clear duplicates between columns

I have this code that I'm trying to get to loop through columns A and D until end.

If it finds a rows where 'A & D' are duplicates, I want it to leave the first instance, and clear the value in column 'D' for the duplicate rows.

So,

A B C D
1 1 1 1
1 1 1 1
1 2 2 2
3 3 3 3  
1 1 1 1

Would become,

A B C D
1 1 1 1
1 1 1 
1 2 2 2
3 3 3 3  
1 1 1

Heres the code so far,

Sub clearDups()

    Dim i As Long
    Dim Lastrow As Long
    Lastrow = Cells(Rows.Count, "A").End(xlUp).row
        For i = 1 To Lastrow
            If Cells(i, 1).Value And Cells(i, 2).Value = Cells(i + 1, 1).Value And Cells(i + 1, 2).Value Then
                Range("D" & i + 1).ClearContents
            End If
        Next
    
    End Sub

Any input appreciated.

Upvotes: 0

Views: 40

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, try the next code:

Sub RemoveDuplAD()
   Dim sh As Worksheet, lastR As Long, i As Long, arr, dict As Object
   
   Set sh = ActiveSheet
   lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
   arr = sh.Range("A2:D" & lastR).Value2
   Set dict = CreateObject("Scripting.Dictionary")
   
   For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 1) & arr(i, 4)) Then
            dict.Add arr(i, 1) & arr(i, 4), vbNullString 'only like reference. This row value in "D:D" will remain
        Else
            arr(i, 4) = ""   'value in "D:D" will be delete
        End If
   Next i
   sh.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value2 = arr
End Sub

Your code could not work. It has a chance to work (with some modifications) only if the duplicate lines are consecutive. The above code, modifies/clear the D:D contents only for the next occurrences, the first one remaining unmodified, independent of the its position/row in the range.

Upvotes: 1

Related Questions