VBA查询：检索缺失值

Sub RetrieveMissingValues()
    
    ' Lookup
    Const LKP_SHEET As String = "CHECK-IN"
    Const LKP_FIRST_CELL As String = "C2"
    ' Source
    Const SRC_SHEET As String = "CHECK-OUT"
    Const SRC_FIRST_ROW As String = "C2:F2"
    ' Destination
    Const DST_SHEET As String = "NOT RETURNED"
    Const DST_FIRST_CELL As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim lws As Worksheet: Set lws = wb.Sheets(LKP_SHEET)
    If lws.FilterMode Then lws.ShowAllData
    
    Dim lData(), lrCount As Long
    
    With lws.Range(LKP_FIRST_CELL)
        Dim llCell As Range: Set llCell = .Resize(lws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If llCell Is Nothing Then Exit Sub
        lrCount = llCell.Row - .Row + 1
        If lrCount = 1 Then
            ReDim lData(1 To 1, 1 To 1): lData(1, 1) = .Value
        Else
            lData = .Resize(lrCount).Value
        End If
    End With
    
    Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
    lDict.CompareMode = vbTextCompare
    
    Dim lr As Long, lStr As String
    
    For lr = 1 To lrCount
        lStr = CStr(lData(lr, 1))
        If Len(lStr) > 0 Then
            If Not lDict.Exists(lStr) Then
                lDict(lStr) = Empty
            End If
        End If
    Next lr
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET)
    If sws.FilterMode Then sws.ShowAllData
    
    Dim sData(), srCount As Long, scCount As Long
    
    With sws.Range(SRC_FIRST_ROW)
        Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If slCell Is Nothing Then Exit Sub
        srCount = slCell.Row - .Row + 1
        scCount = .Columns.Count
        sData = .Resize(srCount).Value
    End With
     
    Dim dData(): ReDim dData(1 To srCount * scCount, 1 To 1)
     
    Dim sr As Long, sc As Long, dr As Long, sStr As String
    
    For sr = 1 To srCount
        For sc = 1 To scCount
            sStr = CStr(sData(sr, sc))
            If Len(sStr) > 0 Then
                If Not lDict.Exists(sStr) Then
                    dr = dr + 1
                    dData(dr, 1) = sData(sr, sc)
                End If
            End If
        Next sc
    Next sr
    
    If dr = 0 Then
        MsgBox "No missing values found.", vbInformation
        Exit Sub
    End If
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    With dws.Range(DST_FIRST_CELL)
        .Resize(dr).Value = dData
        .Resize(dws.Rows.Count - .Row - dr + 1).Offset(dr).Clear
    End With
    
    MsgBox "Missing values retrieved.", vbInformation
    
End Sub