Matching dictionary keys to worksheet cell values

Question

I have not yet found any questions related to this topic, hence my question below.

I'm working with a dictionary, which have keys and items like below.

Keys:  30 31 32 33 34 35 36 37 39
Items: 21 51 31 64 65 32 29 74 61

I also have some values written to the worksheet:

27 28 29 30 31 32 33 34 35 36 37 38 39 40

My goal is to resize the dictionary, and write the Items contained within it to the cell below the cell matching the dictionary key.

So far I've only been able to write the dictionary to a given place in the worksheet ws:

ws.Range("C28").Resize(1, dict.Count).Value2 = dict.Keys
ws.Range("C29").Resize(1, dict.Count).Value2 = dict.Items

I've tried the following code, but this is only a start. Of course, this is not where I'm going but it's all I can think of. Any help or points would be greatly appreciated. Thanks.

Dim key As Variant
Dim cell As Range

With ws
For Each cell In .Range("D10:S10")
    If dict.Exists(cell.Value) Then
        cell.Offset(2, 0).Value = dict.Items
    End If
Next

For Each key In dict
    With .Cells(.Rows.Count, 4).End(xlUp).Offset(1)
        .Value = key
        .Offset(, 2) = dict(key)
    End With
Next

End With

Sample from worksheet result:

Code update after comments (not yet finished for the specific problem, but a proof of concept. It is under development with comments.)

Sub TEST()
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet2")   ' <- change the sheet name
    Dim oDict As New Scripting.Dictionary
    Dim iRow As Long: iRow = oWS.Cells(oWS.Rows.Count, 10).End(xlUp).Row                                      ' <- iRow and be set dynamically
    Dim oCell As Range
    
    oDict.Add 30, 70
    oDict.Add 31, 71
    oDict.Add 32, 72
    oDict.Add 33, 73
    oDict.Add 34, 74
    oDict.Add 35, 75
    oDict.Add 36, 76
    oDict.Add 37, 77
    oDict.Add 38, 78
    oDict.Add 39, 79
    oDict.Add 40, 80
    oDict.Add 42, 82
    
    With oWS
        
        For Each oCell In .Range("A1:P1")
        
            If oDict.Exists(oCell.Value) Then
                iRow = iRow + 1
                '.Cells(1, iRow).Value = oCell.Value
                .Cells(2, iRow).Value = oDict.Item(oCell.Value)
            End If
        
        Next
        
    End With

End Sub

Answer 1

After a lot of trial and error, and great help from @Zac, I've gotten to an answer to my problem:

The final code

Sub SetDictValues()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet2")
    Dim oDict As New Scripting.Dictionary
    Dim iRow As Long
    Dim rKeys As Range
    Dim rUpdateRng As Range
    Dim oCell As Range
    
    iRow = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
    Set rKeys = oWS.Range("A1:A" & iRow)
    
    oDict.Add 30, 70
    oDict.Add 31, 71
    oDict.Add 32, 72
    oDict.Add 33, 73
    oDict.Add 34, 74
    oDict.Add 35, 75
    oDict.Add 36, 76
    oDict.Add 37, 77
    oDict.Add 38, 78
    oDict.Add 39, 79
    oDict.Add 40, 80
    oDict.Add 42, 81
    
    With oWS
        
        For Each oCell In .Range("A1:P1")
        
            If oDict.Exists(oCell.Value) Then
                
                Set rUpdateRng = rKeys.Find(oCell.Value)
                If Not rUpdateRng Is Nothing Then
                    rUpdateRng.Offset(1, 0).Value = oDict.Item(oCell.Value)
                End If
            End If
        
        Next
        
    End With

End Sub

I changedrUpdateRng.Offset(, 2).Value to rUpdateRng.Offset(1, 0).Value and Set rKeys = oWS.Range("A2:A" & iRow) to Set rKeys = oWS.Range("A1:A" & iRow) to avoid overwriting key values.

Answer 2

This might be over simplifying the issue but if i understand your requirements correctly, this should work

Sub SetDictValues()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3")
    Dim oDict As New Scripting.Dictionary
    Dim iRow As Long: iRow = oWS.Cells(oWS.Rows.Count, 1).End(xlUp).Row
    Dim rKeys As Range: Set rKeys = oWS.Range("A2:A" & iRow)
    Dim rUpdateRng As Range
    Dim oCell As Range
    
    oDict.Add 30, 70
    oDict.Add 31, 71
    oDict.Add 32, 72
    oDict.Add 33, 73
    oDict.Add 34, 74
    oDict.Add 35, 75
    oDict.Add 36, 76
    oDict.Add 37, 77
    oDict.Add 38, 78
    oDict.Add 39, 79
    oDict.Add 40, 80
    
    With oWS
        
        For Each oCell In .Range("A1:K1")
        
            If oDict.Exists(oCell.Value) Then
                
                Set rUpdateRng = rKeys.Find(oCell.Value)
                If Not rUpdateRng Is Nothing Then
                    rUpdateRng.Offset(, 2).Value = oDict.Item(oCell.Value)
                End If
            End If
        
        Next
        
    End With
    
End Sub

Answer 3

This should do what you describe:

'...
For Each cell In .Range("D10:S10").Cells
    if dict.Exists(cell.value) Then
        cell.Offset(2, 0).value = dict(cell.Value)
    end if
Next
'...