Issue Using Dictionary to Match Values with VBA

Question

I'm creating a program that searches a table (~8,500) rows and gets a corresponding value. To do this, I created a Dictionary that holds the "Key" and its corresponding "Value" for that big table. In another Dictionary, I am storing ~330 keys that I need to find the values of in the big table. I then compare the keys and values of the two dictionaries to set the values of the 330ish keys. The code is below:

'Create new HashMap to store part numbers
 Dim partsDict As New Scripting.Dictionary

Sub Main()

    Dim apparatus As String
    Dim facility As String

    'Get selected Apparatus and facility
     apparatus = getApparatus()
     facility = getFacility()

     'Call method to add part numbers to partsDict
     addPartNumbersToDict

    'Call method to add part counts from database to partsDict
     addCountsFromDatabaseToDict apparatus, facility

End Sub

Function getApparatus() As String

    Sheets("Results").Select
    Range("B2").Select
    getApparatus = ActiveCell.value
    Exit Function

End Function

Function getFacility() As String

    Sheets("Results").Select
    Range("E2").Select
    getFacility = ActiveCell.value
    Exit Function

End Function

Sub addPartNumbersToDict()

    'Stores last row of sheet
    Dim lastRow As Integer
    'Allows key to be null
    Dim key As Variant

    Sheets("Parts").Select
    ActiveSheet.Cells.UnMerge

    'Get last active row number
     lastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

    'Loop Variable
     Dim i As Integer

    'Loop through list
     For i = 2 To lastRow
        'set key to current cell
         key = Cells(i, 2).value
    
        'ignore empty cells
         If (Not (IsEmpty(key))) Then
        
            'if key hasn't been seen before
             If Not partsDict.Exists(key) Then
                'add key to dictionary
                 partsDict.Add key, 1
            End If
        
        End If
    Next

End Sub

Sub addCountsFromDatabaseToDict(apparatus As String, facility As String)

    'Set WorkBook as database and activate it
     Dim wk As Workbook
     Set wk = Workbooks.Open("Path")
     wk.Activate

    'Filter table
     ActiveSheet.ListObjects("Table_BuyDesign_ChannelSales_Query").Range.AutoFilter _
        Field:=1, Criteria1:=apparatus
     ActiveSheet.ListObjects("Table_BuyDesign_ChannelSales_Query").Range.AutoFilter _
        Field:=2, Criteria1:=facility

    'Create worksheet variable and set it to table sheet
     Dim ws As Worksheet
     Set ws = ActiveWorkbook.Sheets("Data")

    'Create new dictionary for all parts in table
     Dim allParts As New Scripting.Dictionary

     'Create range to hold area of search
      Dim partRange As Range
     'This array holds data in partsRange
     Dim currData As Variant

     'Range of filtered data
      Dim filRange As Range
      Set filRange = ws.Range("D2:E:E").SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants)

    'Loop through filtered data adding all parts and counts for searching
     For Each partRange In filRange.Areas
         currData = partRange
    
        Dim i As Long
        For i = 1 To UBound(currData, 1)
        
            If Not (allParts.Exists(currData(i, 1))) Then
                 allParts(currData(i, 1)) = currData(i, 2)
            End If
        Next i

    Next partRange

    For Each key In partsDict
         If allParts.Exists(key) Then
             partsDict(key) = allParts(key)
         Else
             partsDict(key) = Empty
         End If
    Next key

End Sub

I know that the Dictionary with all ~8,500 rows has been populated correctly (I printed it out). However, the setting of my keys is not working properly. Less than 10 of the 330 keys have values assigned to them. The rest are empty. Is my element checking wrong?

The main problem subroutine is addCountsFromDatabaseToDict() and more specifically, the last for loop in that subroutine. I added the entire program for clarity. Thank you!