比较不同工作表中的两列，并创建一条消息，列出缺失的数据

Question

我确信这个查询在其他地方得到了回答，但我似乎找不到它。我基本上在同一工作簿中的两个工作表中都有信息，需要进行比较，并且需要在消息中列出一个工作表缺少的值。两个工作表中都有重复的值，所以只需要一个唯一的缺失值列表。例如：

表1A列1.2.1.5.5.2.3.5.4

表2B列2.3.3.4.3.4

消息框应该声明数据集中缺少1和5，因为它不在Sheet2中。

非常感谢！

Answer 1

花几个小时为您编写一个宏。

在下面的代码中，您只需要更改工作簿名称、工作表名称和第一个单元格的范围。

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