compare and Extract unique values between 2 columns

TroyB

New Member
Joined
Nov 12, 2019
Messages
18
Hello All

I am trying to create a macro that will Compare data in two columns (on two sheets (sheet1 Column B, sheet2 Column A) and add any missing unique values from sheet 1 to sheet 2


Sheet1 column B

Items#s

Item 1
Item 2
Item 1
Item 4
Item 1
Item 2
Item 3
Item 4
Item 5
Item 6


Sheet2 Column A

Item#s
Item 1
Item 2
Item 4
Item 3
Item 5

After Running Item 6 would be added to the last row of sheet2 Column A



Can you please Help??

Troy
 

Some videos you may like

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

VBE313

Well-known Member
Joined
Mar 22, 2019
Messages
674
Office Version
  1. 365
Platform
  1. Windows
Hi Troy,

Please add the following Sub Procedure and Function to a Module in your Workbook. I assumed that your range in Sheet1 is B2:B1000, you can change that to make your code work properly if need be.

VBA Code:
Sub test() 'Help from [URL='https://stackoverflow.com/questions/5890257/populate-unique-values-into-a-vba-array-from-excel']Populate unique values into a VBA array from Excel[/URL]

Dim tmp As String

Dim arr() As String

Dim i As Double

Dim lastrow As Long

    If Not Selection Is Nothing Then

        For Each cell In Sheets("Sheet1").Range("B2:B1000")

            If (cell <> "") And (InStr(tmp, cell) = 0) Then

                tmp = tmp & cell & "|"

                i = i + 1

            End If

        Next cell

    End If

    If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)

        arr = Split(tmp, "|")

        For i = 1 To i

            Sheets("Sheet2").Activate

            lastrow = Cells(Rows.Count, 1).End(xlUp).Row

            Cells(lastrow, 1).Offset(1, 0).Select

            ActiveCell.Value = ExtractNthWord(tmp, 0 + i)

        Next i

End Sub

Function ExtractNthWord(x As String, y As Integer) 'Help from [URL='https://www.exceltip.com/tips/how-to-extract-nth-word-from-text-string-using-vba-in-microsoft-excel-2010.html']How to Extract Nth Word from Text String Using VBA in Microsoft Excel[/URL]

Dim word() As String

Dim wordCount As Long

    word = VBA.Split(x, "|")

    wordCount = UBound(word)

    If wordCount < 1 Or (y - 1) > wordCount Or y < 0 Then

        ExtractNthWord = ""

    Else

        ExtractNthWord = word(y - 1)

    End If

End Function
 

sandy666

Banned - Rules violations
Joined
Oct 24, 2015
Messages
7,499
another way with Power Query
Code:
let
    Combine = Table.Combine({Table1, Table2}),
    Distinct = Table.Distinct(Combine)
in
    Distinct
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,727
Office Version
  1. 365
Platform
  1. Windows
Another option
VBA Code:
Sub TroyB()
    Dim Cl As Range
    Dim Dic As Object
    
    Set Dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
        For Each Cl In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
            Dic.Item(Cl.Value) = Empty
        Next Cl
    End With
    With Sheets("Sheet2")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Dic.Exists(Cl.Value) Then Dic.Remove Cl.Value
        Next Cl
        .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count).Value = Application.Transpose(Dic.Keys)
    End With
End Sub
 

VBE313

Well-known Member
Joined
Mar 22, 2019
Messages
674
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Another option
VBA Code:
Sub TroyB()
    Dim Cl As Range
    Dim Dic As Object
   
    Set Dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
        For Each Cl In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
            Dic.Item(Cl.Value) = Empty
        Next Cl
    End With
    With Sheets("Sheet2")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Dic.Exists(Cl.Value) Then Dic.Remove Cl.Value
        Next Cl
        .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count).Value = Application.Transpose(Dic.Keys)
    End With
End Sub
Legend!!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Another macro for you to consider.

VBA Code:
Sub compare_Extract_unique_values()
  Dim a() As Variant, dic As Object, i As Long
 
  a = Sheets("sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Value2
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    dic(a(i, 1)) = Empty
  Next
  For i = 2 To Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
    If Not dic.exists(Sheets("Sheet1").Range("B" & i).Value) Then
      Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2).Value = Sheets("Sheet1").Range("B" & i).Value
    End If
  Next
End Sub
 

TroyB

New Member
Joined
Nov 12, 2019
Messages
18
Wow, Thank you for all for the great responses

They all seem to work well..

I forgot one thing when I was putting in the request, I only need the unique from Sheet1 Column B if Column C ="" (blank cell)

An additional thing to note might be that there are blank cells in the data in Column B of Sheet1 also

Can you add that into the code?
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Try this

Rich (BB code):
Sub compare_Extract_unique_values()
  Dim a() As Variant, dic As Object, i As Long
  
  a = Sheets("sheet2").Range("A2", Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)).Value2
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  For i = 1 To UBound(a)
    dic(a(i, 1)) = Empty
  Next
  For i = 2 To Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
    If Not dic.exists(Sheets("Sheet1").Range("B" & i).Value) And Sheets("Sheet1").Range("C" & i).Value = "" Then
      Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2).Value = Sheets("Sheet1").Range("B" & i).Value
    End If
  Next
End Sub
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
52,727
Office Version
  1. 365
Platform
  1. Windows
Maybe
VBA Code:
Sub TroyB()
    Dim Cl As Range
    Dim Dic As Object
    
    Set Dic = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
        For Each Cl In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
            If Cl.Value <> "" And Cl.Offset(, 1).Value <> "" Then Dic.Item(Cl.Value) = Empty
        Next Cl
    End With
    With Sheets("Sheet2")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Dic.Exists(Cl.Value) Then Dic.Remove Cl.Value
        Next Cl
        .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Dic.Count).Value = Application.Transpose(Dic.Keys)
    End With
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,122,168
Messages
5,594,632
Members
413,919
Latest member
ZaxAlchemist

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