excel - 字典比较，其中一个键对两列有更多项

Question

我有下面的代码从下面的附件 创建字典“ key 和项目数据库.xlsx”它将存储数据的位置，如下所示。
Sample files are here

Option Explicit
Dim MyKeys As Dictionary

Private Sub crtdic()
    Dim wbk As Workbook
    Dim NewFile As Variant
    Dim lrow As Long

    NewFile = Application.GetOpenFilename("microsoft excel files (*.xls*), *.xlsm*")

    If NewFile <> False Then
        Set wbk = Workbooks.Open(NewFile)
    End If

    lrow = wbk.ActiveSheet.Cells(wbk.ActiveSheet.Rows.Count, "G").End(xlUp).Row

    Dim Keys As Variant: Keys = wbk.ActiveSheet.Range("G2:H" & lrow).Value
    Set MyKeys = New Dictionary

    Dim i As Long      
    For i = 2 To UBound(Keys)         
        With MyKeys
            If .Exists(Keys(i, 1)) Then
                MyKeys(Keys(i, 1)) = MyKeys(Keys(i, 1)) & "," & Keys(i, 2)
            Else
                .Add Keys(i, 1), Keys(i, 2)
            End If
        End With
    Next i

    wbk.Close SaveChanges:=False
End Sub

我要达到的是
使用 我的 key 我需要检查的字典查找文件 1 到查找文件 3 将在一个单独的文件夹中(附加在上面的链接中)，其中 key 将在 BS 及其项目 在 CI栏 , 查找是否有任何新的 Key 或 item 不在字典中 我的 key .
如果找到任何新的键或项，则需要创建一个新字典，该字典需要存储站点名称(查找文件中的 A 列)以及键和项，如下所示

在新工作表或文件中需要打印如下报告。 (请参阅随附的“Missing KEY & Items.xlsx”文件)

这是可行的吗？如果是，请指导我。
使用 我的 key 字典我刚刚做了一个模型测试，我可以使用以下代码获取存在或非退出项。但是我什么也没得到:(

Sub pntdic()
    Dim rng As Range, cell As Range
    Dim c As Integer, c1 As Integer
    Dim sht As Worksheet

    Set sht = ActiveSheet
    Set rng = Selection
    Call crtdic

    sht.Activate

    For Each cell In rng
        If MyKeys.Exists(cell.Value) Then
            If MyKeys.Item(cell.Value) = cell.Value Then
                cell.Offset(0, 2) = "Yes"
            Else
                cell.Offset(0, 2) = "no"
            End If       
        End If 
    Next
End Sub

Answer 1

有趣的是，可以创建字典字典。以下解决方案为源数据(在“Key & items Data Base.xlsx”中)和找到的每个站点名称(通过使用站点名称作为键)创建唯一键和关联项的列表。这对一系列字典来说是有益的，因为这意味着站点名称不需要对于工作表来说是唯一的。

Option Explicit

Private Sub crtdic()
    Const folderName As String = "folder" 'set folder name here
    Const noSite As String = "None"
    Const joinItem As String = ","
    
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim lrow As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim add As Boolean
    
    Dim KeysSite As Variant
    Dim KeysKeys As Variant
    Dim KeysItems As Variant
    Dim KeysCompareItems As Variant
    
    Dim oFSO As Object
    Dim oFolder As Object
    Dim oFile As Object
    Dim path As String
    Dim dicts As Object
    Dim dict As Object

    Set dicts = CreateObject("Scripting.Dictionary")
    Set dict = CreateObject("Scripting.Dictionary")
    
    'Current workbook - source keys and items
    Set wsh = ThisWorkbook.Sheets(1)
    
    lrow = wsh.Cells(wsh.Rows.Count, "G").End(xlUp).Row

    KeysKeys = wsh.Range("G2:G" & lrow).Value
    KeysItems = wsh.Range("H2:H" & lrow).Value
    
    dicts.add noSite, dict
    Set dict = Nothing

    For i = 1 To UBound(KeysKeys)
        If dicts(noSite).Exists(KeysKeys(i, 1)) Then
            dicts(noSite)(KeysKeys(i, 1)) = dicts(noSite)(KeysKeys(i, 1)) & joinItem & KeysItems(i, 1)
        Else
            dicts(noSite).add KeysKeys(i, 1), KeysItems(i, 1)
        End If
    Next i
    
    'Folder files
    path = ActiveWorkbook.path & "\" & folderName & "\"
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(path)
    
    For Each oFile In oFolder.Files
        If 0 <> InStr(oFile.Name, ".xls") Then
            Set wbk = Workbooks.Open(path & oFile.Name)
            Set wsh = wbk.ActiveSheet
            
            lrow = wsh.Cells(wsh.Rows.Count, "A").End(xlUp).Row
            
            KeysSite = wsh.Range("A2:A" & lrow).Value
            KeysKeys = wsh.Range("BS2:BS" & lrow).Value
            KeysItems = wsh.Range("CI2:CI" & lrow).Value
            
            For i = 1 To UBound(KeysSite)
                If Not dicts(noSite).Exists(KeysKeys(i, 1)) Then
                    add = True
                Else
                    'Check for full match
                    KeysCompareItems = Split(dicts(noSite)(KeysKeys(i, 1)), joinItem)
                    add = True
                    
                    For j = 0 To UBound(KeysCompareItems)
                        If KeysCompareItems(j) = KeysItems(i, 1) Then
                            add = False
                            Exit For
                        End If
                    Next j
                End If
                
                If add = True Then
                    If dicts.Exists(KeysSite(i, 1)) Then
                        If dicts(KeysSite(i, 1)).Exists(KeysKeys(i, 1)) Then
                            dicts(KeysSite(i, 1))(KeysKeys(i, 1)) = dicts(KeysSite(i, 1))(KeysKeys(i, 1)) & joinItem & KeysItems(i, 1)
                        Else
                            dicts(KeysSite(i, 1)).add KeysKeys(i, 1), KeysItems(i, 1)
                        End If
                    Else
                        Set dict = CreateObject("Scripting.Dictionary")
                        dicts.add KeysSite(i, 1), dict
                        Set dict = Nothing
                        dicts(KeysSite(i, 1)).add KeysKeys(i, 1), KeysItems(i, 1)
                    End If
                End If
            Next i
            
            wbk.Close SaveChanges:=False
            Set wsh = Nothing
            Set wbk = Nothing
        End If
    Next oFile
    
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFSO = Nothing
    
    'Write dictionary values
    Set wsh = ThisWorkbook.Sheets.add(After:=Sheets(Sheets.Count))
    
    wsh.Activate
    
    lrow = 1
    
    Cells(lrow, 1) = "Site Name"
    Cells(lrow, 2) = "Key"
    Cells(lrow, 3) = "Item"
    
    KeysSite = dicts.Keys
    
    For i = 0 To dicts.Count - 1
        If KeysSite(i) <> noSite Then
            For j = 0 To dicts(KeysSite(i)).Count - 1
                KeysKeys = dicts(KeysSite(i)).Keys
                KeysItems = Split(dicts(KeysSite(i))(KeysKeys(j)), joinItem)
                
                For k = 0 To UBound(KeysItems)
                    lrow = lrow + 1
                    Cells(lrow, 1) = KeysSite(i)
                    Cells(lrow, 2) = KeysKeys(j)
                    Cells(lrow, 3) = KeysItems(k)
                Next k
            Next j
        End If
    Next i
End Sub

要运行此解决方案:

打开“Key & items Data Base.xlsx”(单独)并将此代码粘贴到新模块

设置folderName固定到您的文件夹名称(假定此文件夹位于包含“Key & items Data Base.xlsx”的文件夹内，并且假定此子文件夹仅包含查找文件)

运行crtdic

包含找到的新 key 和项目的新工作表已添加到“ key 和项目数据库.xlsx”

使用提供的文件运行此代码时的结果是: