Compare two columns in different worksheets and create a message listing the missing data-CodePudding

I'm sure this query has been answered somewhere else but I can't seem to find it. I basically have information in two worksheets in the same workbook which need to be compared and the missing values from one worksheet need to be listed in a message. There are duplicate values in both worksheets so only need a list of the unique missing values. For example:

Sheet1 Column A 1 2 1 5 5 2 3 5 4

Sheet2 Column B 2 3 3 4 3 4

The message box should state that we are missing 1 and 5 from the dataset as it is not in Sheet2.

Many thanks!

CodePudding user response：

Spend som hours to write a macro for you.

In the code below you just need to change the workbook name, sheet name and range for first cell.

Sub Compare2Columns()
    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim LastRow1 As Long
    Dim LastRow2 As Long
    Dim FirstCell1 As Range
    Dim FirstCell2 As Range
    
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    
    '*******************
    Set wb = Workbooks("Compare Lists with Dictionary.xlsm") ''change to your needs  or use thisworkbook
    Set ws1 = wb.Worksheets("sheet1") 'change to your needs
    Set ws2 = wb.Worksheets("sheet2") 'change to your needs
    
    Set FirstCell1 = ws1.Range("A2") 'change to your needs
    Set FirstCell2 = ws2.Range("A2") 'change to your needs
    '*********************
    
    
    LastRow1 = ws1.Cells(Rows.Count, FirstCell1.Column).End(xlUp).Row
    LastRow2 = ws2.Cells(Rows.Count, FirstCell2.Column).End(xlUp).Row
    
    'Read data to arrays
    arr1 = ws1.Range(FirstCell1, ws1.Cells(LastRow1, FirstCell1.Column))
    arr2 = ws2.Range(FirstCell2, ws2.Cells(LastRow2, FirstCell2.Column))
    
    
    
    '1)Read First Data from first column into a dictionary
    Dim Col1Dic As Object 'Declare late binding
    Set Col1Dic = CreateObject("Scripting.Dictionary") 'Create late binding
    
    For i = LBound(arr1) To UBound(arr1)
        Col1Dic(arr1(i, 1)) = 0
    Next i

    '2) Read Second Data from second column into a dictionary
    Dim Col2Dic As Object
    Set Col2Dic = CreateObject("Scripting.Dictionary")
   
    
    For i = LBound(arr2) To UBound(arr2)
        Col2Dic(arr2(i, 1)) = 0
    Next i
    
    'Data which is available in First Column, but not in Second Column
    Dim dicOnlyIn_1st As Object 'List of Sheets which are only in the Workbook (NEW Sheets)
    Set dicOnlyIn_1st = CreateObject("Scripting.Dictionary")
    
    
    Dim item As Variant
    
    'Comparing 2 dictionaries
    For i = 0 To Col1Dic.Count - 1
        item = Col1Dic.Keys()(i)
        
        If Col2Dic.Exists(item) = False Then
            dicOnlyIn_1st(item) = 0
        Else
            Col2Dic.Remove (item)
        End If
    Next i
    
   Dim key As Variant
   Dim str As String
    
'    'creating the Messagebox
'    i = 1
'    For Each key In dicOnlyIn_1st
'        If i < dicOnlyIn_1st.Count Then
'            str = str & key & ",  "
'        Else
'            str = str & key & "  "
'        End If
'        i = i   1
'    Next key
'
'    MsgBox str & " are unique values in First column"
'
    
    '********write results to a worksheet**********
    Dim wsResult As Worksheet
    Dim FirstCell3 As Range
    Dim LastRow3 As Long
    
    Set wsResult = ThisWorkbook.Worksheets("sheet3") 'change worksheetname here
    Set FirstCell3 = wsResult.Range("A2") ' change Startcell here
    LastRow3 = wsResult.Cells(Rows.Count, FirstCell3.Column).End(xlUp).Row
    
    'delete old data
    If FirstCell3.Row < LastRow3 Then
         wsResult.Range(FirstCell3, wsResult.Cells(LastRow3, FirstCell3.Column)).ClearContents
    End If
    
    FirstCell3.Resize(dicOnlyIn_1st.Count, 1).Value = WorksheetFunction.Transpose(dicOnlyIn_1st.Keys)
    
    
End Sub