Dictionary comparison where one key has more item against two columns

Question

I have the below code to create a dictionary from the below attached file "Key & items Data Base.xlsx" where it will store data as shown below.

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

What I want to achieve is

Using MyKeys dictionary I need to check in Lookup file1 to lookup file3 will be in a separate folder (attached in the above link) where Key will be there in column BS and its Item in column CI, to find is there any new Key or item are there which are not in the dictionary Mykeys.

If there are any new keys or items found then, need to create one new dictionary which will need to store site name (column A in the look up files) along with the keys and items like the below

In new sheet or file need to print report like the below. (Kindly refer the attached "Missing KEy & Items.xlsx" file)

Is this doable? if yes kindly guide me.

Using the Mykeys dictionary I just did a mockup test where I can get the exist or non exits item by using the following code. However I'm not getting anything :(

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

user_2687204 · Answer

Interestingly, it is possible to create a dictionary of dictionaries. The below solution creates a list of unique keys and associated items for the source data (in 'Key & items Data Base.xlsx') and for each site name found (by using the site name as a key). This is beneficial over an array of dictionaries, as it means a site name does not need to be unique to a worksheet for this to work.

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

To run this solution:

Open 'Key & items Data Base.xlsx' (on its own) and paste this code into a new module
Set the folderName constant to your folder name (this folder is assumed to be inside the folder which contains 'Key & items Data Base.xlsx' and this subfolder is assumed to only contain the lookup files)
Run crtdic
A new sheet containing the new keys & items found is added to 'Key & items Data Base.xlsx'

The result when running this code with the files provided is:

Dictionary comparison where one key has more item against two columns

1 Answers