VBA to Extract unique values from multiple columns in to one column

[leesjason]

Hello,

I'm a new member and I'm not entirely sure how this forum works and where to post questions.
I've been searching on this site as well as online and did manage to find some info, but none of them seem to work or doesn't apply.

Issue: I have a workbook with multiple tabs; each tab does something different.
In the first summary tab, I have 3 different columns (say columns A, G, & L) that lists hundreds of serial numbers (no letter characters) there are duplicates in all 3 columns.
I need to extract all unique serial numbers from all 3 columns in to one separate combined column within the same tab - so that the result is one column with all unique serial numbers in only the summary tab.

Is there a VBA macro that can do this; not using ARRAY formulas?

I can do the formula method; but I am looking for a VBA to prevent the file from crashing.
ARRAY formulas seems to take up a TON of processing power and takes over 20min just to save.

I have found several VBA that can extract unique values from one column in to a separate column but there seems to be no info on extracting from multiple columns.
The VBA macro I've been using for single column extraction is below, extracting values from column A, and pasting it to column B.

Option ExplicitSub CreateUniqueList()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    
    ActiveSheet.Range("A2:A" & lastrow).AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=ActiveSheet.Range("B2"), _
    unique:=True
     
End Sub

I've been playing with this Macro to incorporate multiple columns...but nothing seems to work.
PS - I am relatively new to VB Macros; although I am an experienced Excel user.

Any help would be much appreciated.
Thank you!

 

[Roderick_E]

hmm maybe use countifs to determine if the value is unique (appears on 1 time)

if application.countifs(criteria range, criteria) = 1 then....

 

[leesjason]

hmm maybe use countifs to determine if the value is unique (appears on 1 time)

if application.countifs(criteria range, criteria) = 1 then....

Thanks for the reply. I'm unsure how I could add countifs to parse through 3 different ranges on 3 differently columns.

I'm thinking, wouldn't I need to use some sort of combine range or Union (to join 3 different columns); then using the combined object range parse for unique values?
But I'm not too familiar with VB; and so, don't know how I would code this.

I've been playing with VBE: Union to combine 3 ranges (but doesn't seem to combine the values within those ranges)

Sub MultipleRange()
    Dim r1, r2, r3, myMultipleRange As Range
    Set r1 = Sheets("Sheet1").Range("A2:A")
    Set r2 = Sheets("Sheet1").Range("G2:G")
    Set r3 = Sheets("Sheet1").Range("L2:L")
    Set myMultipleRange = Union(r1, r2, r3)
    myMultipleRange.Font.Bold = True
End Sub

 

[Eric W]

You could try something like this:

Sub ThreeColDupes()
Dim MyDict As Object, MyCols As Variant, OutCol As String, LastRow As Long
Dim InputSh As Worksheet, OutputSh As Worksheet
Dim x As Variant, i As Long, MyData As Variant

    Set MyDict = CreateObject("Scripting.Dictionary")

    Set InputSh = Sheets("Sheet6")
    MyCols = Array("A", "G", "L")
    
    Set OutputSh = Sheets("Sheet6")
    OutCol = "X"
    
    For Each x In MyCols
        LastRow = InputSh.Cells(Rows.Count, x).End(xlUp).Row
        MyData = InputSh.Range(x & "1:" & x & LastRow).Value
        For i = 1 To UBound(MyData)
            If MyData(i, 1) <> "" Then MyDict(MyData(i, 1)) = 1
        Next i
    Next x

    OutputSh.Range(OutCol & "1").Resize(MyDict.Count, 1).Value = WorksheetFunction.Transpose(MyDict.keys)
    
End Sub

Change the parts in red to match your workbook.

 

[leesjason]

Thank you so much! It works like magic!

If I may, how would this VBE change if I need the previously rendered serial numbers to erase before a new set of serial numbers are extracted from the new data set?

This extraction would occur at every month; and so the previously extracted data would have to be erased before the new one is extracted.

When I run the single column VBA extraction (above); it erases all previous data before extracting from new data.

 

[Eric W]

Add this line just before the last line:

    OutputSh.Range(OutCol & ":" & OutCol).ClearContents

Glad I could help!

 

[Lewzerrrr]

You could try something like this:

Sub ThreeColDupes()
Dim MyDict As Object, MyCols As Variant, OutCol As String, LastRow As Long
Dim InputSh As Worksheet, OutputSh As Worksheet
Dim x As Variant, i As Long, MyData As Variant

    Set MyDict = CreateObject("Scripting.Dictionary")

    Set InputSh = Sheets("Sheet6")
    MyCols = Array("A", "G", "L")
    
    Set OutputSh = Sheets("Sheet6")
    OutCol = "X"
    
    For Each x In MyCols
        LastRow = InputSh.Cells(Rows.Count, x).End(xlUp).Row
        MyData = InputSh.Range(x & "1:" & x & LastRow).Value
        For i = 1 To UBound(MyData)
            If MyData(i, 1) <> "" Then MyDict(MyData(i, 1)) = 1
        Next i
    Next x

    OutputSh.Range(OutCol & "1").Resize(MyDict.Count, 1).Value = WorksheetFunction.Transpose(MyDict.keys)
    
End Sub

Change the parts in red to match your workbook.

Apologies in digging this up.

How can I change the MyCols = Array() to a more user input range? Say I needed to look down A through to BS, rather than manually entering ("A", "B", "C", "D", ...)..

Could it be something like MyCols = Array(1 to 40) or an input box where a user selects a range?

My actual situation would be to have multiple columns of data, it could be A:C or B:BA and the output to be activecell

 

[Eric W]

I streamlined the code a bit. It may run a tad slower, if that's an issue, I can speed it up at the cost of adding some complexity back.

Sub ManyColDupes()
Dim MyDict As Object, InputRange As Range, OutputCol As Range, z As Variant, c As Variant

    Set MyDict = CreateObject("Scripting.Dictionary")
    Set InputRange = Sheets("Sheet6").Range("D1:BS1,CC1")
    Set OutputCol = Sheets("Sheet7").Range("X1")
    
    On Error Resume Next
    For Each c In InputRange
        For Each z In Range(c, c.Offset(Rows.Count - 1).End(xlUp))
            If z <> "" Then MyDict(CStr(z)) = 1
        Next z
    Next c

    OutputCol.Resize(MyDict.Count, 1).Value = WorksheetFunction.Transpose(MyDict.keys)
    
End Sub

For the I/O, just change the ranges in red. The ranges should all be row 1. But for the InputRange, you can change the range in red to any valid range, so you can select a range of columns, or even disjoint columns. If you really want an Inputbox, let me know. You can change:

Set OutputCol = Sheets("[COLOR=#ff0000]Sheet7[/COLOR]").Range("[COLOR=#ff0000]X1[/COLOR]")

to

Set OutputCol = ActiveCell

if you want.

Also, the Transpose function I use at the end has an upper limit of about 65K. If your list is longer than that, I can work around it.

Hope this helps.