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

leesjason

New Member
Joined
Jan 20, 2017
Messages
4
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.

Code:
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!
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Roderick_E

Well-known Member
Joined
Oct 13, 2007
Messages
2,051
hmm maybe use countifs to determine if the value is unique (appears on 1 time)
Code:
if application.countifs(criteria range, criteria) = 1 then....
 

leesjason

New Member
Joined
Jan 20, 2017
Messages
4
hmm maybe use countifs to determine if the value is unique (appears on 1 time)
Code:
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)

Code:
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

MrExcel MVP
Joined
Aug 18, 2015
Messages
10,608
You could try something like this:

Rich (BB code):
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

New Member
Joined
Jan 20, 2017
Messages
4

ADVERTISEMENT

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

MrExcel MVP
Joined
Aug 18, 2015
Messages
10,608
Add this line just before the last line:

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

Glad I could help! :cool:
 

Lewzerrrr

Active Member
Joined
Jan 18, 2017
Messages
251
You could try something like this:

Rich (BB code):
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
 
Last edited:

Eric W

MrExcel MVP
Joined
Aug 18, 2015
Messages
10,608
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.
Rich (BB code):
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:

Code:
Set OutputCol = Sheets("[COLOR=#ff0000]Sheet7[/COLOR]").Range("[COLOR=#ff0000]X1[/COLOR]")
to
Rich (BB code):
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.
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,122,352
Messages
5,595,657
Members
414,006
Latest member
Davefromlondon

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top