Follow

Keep Up to Date with the Most Important News

By pressing the Subscribe button, you confirm that you have read and are agreeing to our Privacy Policy and Terms of Use
Contact

VBA Excel – Remove Duplicates in both columns

I have a dataset with two columns as below. The values A, B and C are duplicates and I want them removed in both columns by using VBA, and end up with the table as shown in second table.

Column 1    Column 2
a           b
c           x
f           z
b           a
e           c
d           y
Column 1    Column 2
f           x
e           z
d           y

I have tried working with the Remove.Duplicates method, but this did not work. Even when I made sure the duplicates were in the same row

ActiveSheet.Range("A:B").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

Any suggestions?

MEDevel.com: Open-source for Healthcare and Education

Collecting and validating open-source software for healthcare, education, enterprise, development, medical imaging, medical records, and digital pathology.

Visit Medevel

>Solution :

If I understand you correctly… maybe something like this

Sub test()
Dim rg As Range: Dim rgDel As Range: Dim cell As Range
Dim arr: Dim el

'set the range of data - change if needed
Set rg = Range("A2", Range("B" & Rows.Count).End(xlUp))

'create arr variable which contains only unique value
Set arr = CreateObject("scripting.dictionary")
For Each cell In rg: arr.Item(cell.Value) = 1: Next

'loop to each element in arr as el variable
'get the range of cell/s which value is the looped element as rgDel variable
'check if the count of rgDel is >= 2 then delete shift up the rgDel
'if the count is < 2 then replace back the "TRUE" value to el
For Each el In arr
    With rg
        .Replace el, True, xlWhole, , False, , False, False
        Set rgDel = .SpecialCells(xlConstants, xlLogical)
        If Application.CountA(rgDel) >= 2 Then
            rgDel.Delete Shift:=xlUp
        Else
            .Replace True, el, xlWhole, , False, , False, False
        End If
    End With
Next
End Sub
Add a comment

Leave a Reply

Keep Up to Date with the Most Important News

By pressing the Subscribe button, you confirm that you have read and are agreeing to our Privacy Policy and Terms of Use

Discover more from Dev solutions

Subscribe now to keep reading and get access to the full archive.

Continue reading