Compare column A and B and create new column that contains values that only exist in column A

Viewed 218

There are a few questions that ask something similar but not the exact thing.

I have two columns X and Y. Y contains only values that exist in X. I want to create a column Z that has all the values that exist only in X.

  • X and Y can contain duplicate data as shown in the example
  • X exists in sheet1 whilst Y and Z exist in sheet2
X Y Z
a c a
b e b
b d
c e
d
e

So far, I recorded a macro so naturally the code is super slow, despite my best efforts to clean it up. I won't post the whole code because it's quite messy but essentially I've

  1. Used the unique() function to create two columns that contain the unique values of X and Y respectively.

  2. Used vlookup() to create an adjacent column to the two I just created that returns an empty string if the adjacent unique X value exists in the unique Y column else returning the X value. This part is horribly slow. I created the formula in one cell then pasted it down.

Range("U2").Formula2R1C1 = "=UNIQUE('1.HoldingCart'!C[-18])"
Range("V2").Formula2R1C1 = "=UNIQUE(C[-19])"
Range("W3").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2], C[-1], 1, FALSE)), RC[-2], """")"
Range("W3").Copy
Range("W3:W" & Cells(Rows.Count, "U").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

enter image description here

  1. Filtered out all the empty strings on the vlookup() column. Copied the actual values. Got rid of the filter. Deleted everything and then pasted the copied data thus creating column Z.
' Get the discrepancies
ActiveSheet.Range("$W:$W").AutoFilter Field:=1, Criteria1:="<>"
Range("W2:W" & Cells(Rows.Count, "W").End(xlUp).Row).Copy
Range("X2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=False

' Clean the sheet
ActiveSheet.ShowAllData
Selection.AutoFilter
Range("U2:W" & Cells(Rows.Count, "W").End(xlUp).Row).ClearContents

' Paste the discrepancies
Range("X2:X" & Cells(Rows.Count, "X").End(xlUp).Row).Cut
Range("U2").Select
ActiveSheet.Paste

Sorry you just had to read that horrible code. I'm happy to throw all that away. Any help would be appreciated.

3 Answers

I see you do not mind to let go of VBA, but are willing to use a formula instead. With microsoft365, you can use:

enter image description here

Formula in C2

=UNIQUE(FILTER(A2:INDEX(A:A,MATCH("ZZZ",A:A)),COUNTIF(B2:INDEX(B:B,MATCH("ZZZ",B:B)),A2:INDEX(A:A,MATCH("ZZZ",A:A)))=0))

If you do want to go through VBA, then maybe use a Dictionary. A crude example could be:

Sub Test()

Dim LrA As Long, LrB As Long, x As Long
Dim arrA As Variant, arrB As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")

With ws
    
    'Get last used rows
    LrA = .Cells(.Rows.Count, 1).End(xlUp).Row
    LrB = .Cells(.Rows.Count, 2).End(xlUp).Row
    
    'Initialize arrays
    arrA = .Range("A2:A" & LrA).Value
    arrB = .Range("B2:B" & LrB).Value
    
    'Run over arrA and fill Dictionary
    For x = LBound(arrA) To UBound(arrA)
        dict(arrA(x, 1)) = 1
    Next
    
    'Run over arrB and remove from Dictionary
    For x = LBound(arrB) To UBound(arrB)
        If dict.Exists(arrB(x, 1)) Then dict.Remove arrB(x, 1)
    Next
    
    'Pull remainder from dictionary
    .Cells(2, 3).Resize(dict.Count).Value = dict.Keys
    
End With

End Sub

Alternative via user defined function Unique2() (vs. MS 365)

Benefitting from the new dynamic features of MS 365 you can combine the new (worksheet) function

  • Unique() (available since version 365)

with

  • Application.Match() *(undocumented simultaneous! comparison of two arrays) plus

  • a negative filtering via VBA.Filter() of already existant items to be deleted. - These are identified via IsNumeric() as they return any found positions within the 2nd array (whereas the actually searched uniques would return an error value, which gets ignored by IsNumeric)

Function UNIQUE2(rng1 As Range, rng2 As Range)
Dim x:   x = Application.Unique(rng1)
Dim y:   y = rng2
Dim tmp: tmp = Application.Transpose(Application.Match(x, y, 0))
Dim i As Long
For i = LBound(tmp) To UBound(tmp)
    tmp(i) = IIf(IsNumeric(tmp(i)), "DELETE", x(i, 1))
Next
UNIQUE2 = Application.Transpose(Filter(tmp, "DELETE", False))
End Function

Example call via formula input

Enter the following dynamic (udf) formula e.g. into cell Z1 to get the whole spill range filled:

    =UNIQUE2(X1:X6,Y1:Y4)    

Spill range

Write Unique Column

enter image description here

  • Adjust the values in the constants section.
  • Download a copy of the workbook from Google Drive (down arrow at the top-right)
Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from the Source Column, that are not
'               found in the Lookup Column, to the Destination Column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub writeUniqueColumn()
    Const ProcName As String = "writeUniqueColumn"
    On Error GoTo clearError
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A2"
    Const lName As String = "Sheet2"
    Const lFirst As String = "A2"
    Const dName As String = "Sheet2"
    Const dFirst As String = "B2"
    
    Dim isDataFound As Boolean
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sCell As Range: Set sCell = wb.Worksheets(sName).Range(sFirst)
    Dim sData As Variant: sData = getUniqueColumn(sCell)
    If IsEmpty(sData) Then GoTo ProcExit
    
    Dim lCell As Range: Set lCell = wb.Worksheets(lName).Range(lFirst)
    Dim lData As Variant: lData = getUniqueColumn(lCell)
    If IsEmpty(lData) Then GoTo ProcExit
    
    Dim Indexes As Variant: Indexes = Application.Match(sData, lData, 0)
    Dim sCount As Long: sCount = UBound(sData, 1)
    Dim dCount As Long: dCount = sCount - Application.Count(Indexes)
    
    If dCount = 0 Then GoTo ProcExit
        
    Dim dData As Variant: ReDim dData(1 To dCount, 1 To 1)
    Dim s As Long, d As Long
    For s = 1 To sCount
        If IsError(Indexes(s, 1)) Then
            d = d + 1
            dData(d, 1) = sData(s, 1)
        End If
    Next s
    
    Dim dCell As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
    With dCell
        .Resize(dCount).Value = dData
        .Resize(.Worksheet.Rows.Count - .Row - dCount + 1) _
            .Offset(dCount).ClearContents
    End With
    
    isDataFound = True

ProcExit:
    
    If isDataFound Then
        If dCount = 1 Then
            MsgBox "Found 1 unique value.", vbInformation, "Unique"
        Else
            MsgBox "Found " & dCount & " unique values.", _
                vbInformation, "Unique"
        End If
    Else
        MsgBox "No unique values found", vbExclamation, "No Data"
    End If
    
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from a one-column range
'               to a 2D one-based array, excluding error and blank values.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueColumn( _
    ByVal FirstCell As Range, _
    Optional ByVal Horizontal As Boolean = False) _
As Variant
    Const ProcName As String = "getUniqueColumn"
    On Error GoTo clearError
    
    If Not FirstCell Is Nothing Then
        Dim fCell As Range: Set fCell = FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = fCell.Resize(fCell.Worksheet.Rows.Count - fCell.Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not lCell Is Nothing Then
            Dim rg As Range: Set rg = fCell.Resize(lCell.Row - fCell.Row + 1)
            Dim rCount As Long: rCount = rg.Rows.Count
            Dim Data As Variant
            If rCount = 1 Then
                ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
            Else
                Data = rg.Value
            End If
            Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
            dict.CompareMode = vbTextCompare
            Dim Key As Variant
            Dim n As Long
            For n = 1 To rCount
                Key = Data(n, 1)
                If Not IsError(Key) Then
                    If Len(Key) > 0 Then
                        dict(Key) = Empty
                    End If
                End If
            Next n
            If dict.Count > 0 Then
                n = 0
                If Horizontal Then
                    ReDim Data(1 To 1, 1 To dict.Count)
                    For Each Key In dict.Keys
                        n = n + 1
                        Data(1, n) = Key
                    Next Key
                Else
                    ReDim Data(1 To dict.Count, 1 To 1)
                    For Each Key In dict.Keys
                        n = n + 1
                        Data(n, 1) = Key
                    Next Key
                End If
                getUniqueColumn = Data
            End If
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function
Related