CODEWITHSUNDEEP
vbaexcel
bakman
bakman

Reputation: 11

VBA deleting duplicate values from 2 columns

I have a list with 3 columns

for example

I want to delete any duplicate value with no shifting, the duplicated values can be both on the first column and on the second.

How can I do that?

I've tried something but it didn't work

Sub RemoveDuplicates()
Dim rng As Range
Dim x As Long
Dim lRow As Long
Dim i As Integer

Columns("B:C").Select
    Range("C1").Activate
    Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="0", Replacement:="0", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
i = 1
x = 1
Do While Cells(i, 1).Value <> ""
    Cells(i, 4) = "=CONCATENATE(0,RC[-2])"
    i = i + 1
Loop
Do While Cells(x, 1).Value <> ""
    Cells(x, 5) = "=CONCATENATE(0,RC[-2])"
    x = x + 1
Loop
    Columns("D:E").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Columns("D:E").ClearContents
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

With ThisWorkbook.Sheets(1)
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng = ThisWorkbook.Sheets(1).Range("B2:C" & lRow)
End With

For x = rng.Cells.Count To 1 Step -1
    If WorksheetFunction.CountIf(rng, rng(x)) > 1 Then
        rng(x).ClearContents
    End If
Next x

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Upvotes: 1

Views: 76

Answers (1)

Jordan
Jordan

Reputation: 4514

Try this where your two columns are B and C. It loops through all of the data and uses the worksheet function COUNTIF to check if there is more than one occurrence of each value and clears the contents of the cell if there is a count of more than 1:

Sub RemoveDuplicates()

Dim rng As Range
Dim x as Long
Dim lRow as Long

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

With Thisworkbook.Sheets("SheetName")
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng = .Range("B2:C" & lRow)
End With

For x = rng.Cells.Count To 1 Step -1
    If WorksheetFunction.CountIf(rng, rng(x)) > 1 Then
        rng(x).ClearContents
    End If
Next x

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Upvotes: 1

Related Questions