compare and Extract unique values between 2 columns

[TroyB]

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

 

[VBE313]

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.

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]

another way with Power Query

let
    Combine = Table.Combine({Table1, Table2}),
    Distinct = Table.Distinct(Combine)
in
    Distinct

 

[Fluff]

Another option

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]

Another option

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

 

[sandy666]

I overlooked this

trying to create a macro

 

[DanteAmor]

Another macro for you to consider.

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]

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?

 

[DanteAmor]

Try this

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]

Maybe

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