Using VBA to remove duplicates / write unique values to new column, but have it done in memory / NOT via the .RemoveDuplicates function

[d0rian]

I want to take the values in column A (50,000+ rows) and get only the unique values (there'll be ~2,000) into column B. I currently use the code below, which works perfectly EXCEPT that I've found the .RemoveDuplicates function -- whether run in VBA or via the Excel menus -- really screws up my sheet's formatting and conditional rules. So how can I have the entire process run in the background / in memory? I.e. is there a more elegant way to do it via VBA than copying all the values from col A to B and then running the .RemoveDuplicates function on col B (what the code below does)?

Sub Dedup()
    Range("col_A").Copy
    Range("col_B").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("col_B").RemoveDuplicates Columns:=1, Header:= _
        xlNo
End Sub

 

[Trebor76]

Hi d0rian,

Assuming Row 1 has headings, try this:

Option Explicit
Sub Macro1()

    Dim rngData As Range
    
    Application.ScreenUpdating = False
    
    Set rngData = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

    rngData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B2"), Unique:=True
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[bebo021999]

Assume you 've got user define name "col_A" contains data in column A already.

Option Explicit
Sub Dedup()
Dim cell As Range, i&
With CreateObject("scripting.dictionary")
    For Each cell In Range("col_A")
        If Not .exists(cell.Value) And cell.Value <> "" Then
            .Add cell.Value, ""
        End If
    Next
        For i = 1 To .Count
            Cells(i, "B").Value = .keys()(i - 1)
        Next
End With
End Sub

 

[d0rian]

Hi d0rian,

Assuming Row 1 has headings, try this:

Option Explicit
Sub Macro1()

    Dim rngData As Range
  
    Application.ScreenUpdating = False
  
    Set rngData = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)

    rngData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B2"), Unique:=True
  
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

This works very well and nearly instantaneously (thanks for your reply Bebo, but your code took ~45s to complete), with 1 weird issue: it writes the first value in the dedup'd column twice...in other words, it produces the column B in the attached image from the column A shown..."apple" is printed twice? Looking at code can't quite figure out why this is happening...

 

[Trebor76]

This works very well and nearly instantaneously (thanks for your reply Bebo, but your code took ~45s to complete)

Because my code does not loop.

1 weird issue: it writes the first value in the dedup'd column twice

As Excel's filters all use the first cell as a header so it is ignored when the range is copied and pasted to a new destination. The following will remove the first entry after it's been copied:

Option Explicit
Sub Macro2()
    
    Application.ScreenUpdating = False
    
    Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B2"), Unique:=True
    Range("B2").Delete xlShiftUp
    
    Application.ScreenUpdating = True

End Sub

 

[Trebor76]

If you'd like to use it, here's a way to make bebo021999's method run faster as it does not write each value to the sheet one at a time but all items at the end:

Option Explicit
Sub Dedup()
 
    Dim cell As Range
 
    With CreateObject("Scripting.Dictionary")
        For Each cell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
            If Not .Exists(cell.Value) And cell.Value <> "" Then
                .Add cell.Value, cell.Value
            End If
        Next cell
        ActiveSheet.Cells(2, "B").Resize(.Count) = Application.Transpose(.Items)
    End With
 
End Sub

Regards,

Robert

 

[Peter_SSs]

The following will remove the first entry after it's been copied:

That is a risky method. If the first item in the list only occurs once it would not appear at all in your final list.
Given the layout in the image in post #4 it appears row 1 is blank so I would use an approach like this for Advanced Filter

Sub Macro2_v2()
    Application.ScreenUpdating = False
    Range("A1").Value = "###"
    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    Range("A1:B1").ClearContents
    Application.ScreenUpdating = True
End Sub

If you'd like to use it, here's a way to make bebo021999's method run faster as it does not write each value to the sheet one at a time but all items at the end:

The same argument exists for reading the values from the sheet all at once instead of one at a time so the code below should be considerably faster again.
Depending on the nature & organisation of the original values, for a large data set, it may even be faster than Advanced Filter.

Sub Dedup_v2()
  Dim a As Variant, itm As Variant
  Dim d As Object
 
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  For Each itm In a
    d(itm) = Empty
  Next itm
  Range("B2").Resize(d.Count).Value = Application.Transpose(d.Keys)
End Sub

@d0rian
I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)
eg