How to insert whole columns (Key Value) in Scripting.Dictionary using VBA Macro in Excel Sheet?

Two Columns to Dictionary

Option Explicit

Sub DictTwoColumnsTEST()
' Needs 'DictTwoColumns' and 'GetColumnRange'.
    
    Const wsName As String = "Sheet1"
    Const lrCol As String = "B" ' Last Column Range
    Const kCol As String = "B" ' Key Range
    Const vCol As String = "D" ' Value Range
    Const fRow As Long = 2 ' First Row
        
    ' Workbook, Worksheet
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    ' Create a reference to the source last column range.
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
    Dim rCount As Long: rCount = lRow - fRow + 1
    If rCount < 1 Then Exit Sub ' no data in column range
    Dim lrcrg As Range: Set lrcrg = ws.Cells(fRow, lrCol).Resize(rCount)
    
    ' Create references to the one-column ranges.
    Dim krg As Range: Set krg = lrcrg.EntireRow.Columns(kCol)
    Dim vrg As Range: Set vrg = lrcrg.EntireRow.Columns(vCol)
    
    ' Write the values of the ranges to a dictionary.
    Dim dict As Object: Set dict = DictTwoColumns(krg, vrg)
    
    ' Print keys and values (items).
    Debug.Print Join(dict.Keys, ",")
    Debug.Print Join(dict.Items, ",")
    
    ' Write to a range.
    'Dim drg As Range: Set drg = sws.Range("K2").Resize(dict.Count, 2)
    'drg.Value = Application.Transpose(Array(dict.Keys, dict.Items))
        
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from two same-sized one-column ranges
'               to a dictionary.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictTwoColumns( _
    ByVal KeyRange As Range, _
    ByVal ValueRange As Range) _
As Object
' Needs 'GetColumnRange'.
    
    Dim kData As Variant: kData = GetColumnRange(KeyRange)
    Dim vData As Variant: vData = GetColumnRange(ValueRange)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 1 To UBound(kData, 1)
        If Not dict.Exists(kData(r, 1)) Then
            dict(kData(r, 1)) = vData(r, 1)
        End If
    Next r
    
    Set DictTwoColumns = dict

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from a column ('ColumnNumber')
'               of a range ('rg') to a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnNumber As Long = 1) _
As Variant

    If rg Is Nothing Then Exit Function
    If ColumnNumber < 1 Then Exit Function
    If ColumnNumber > rg.Columns.Count Then Exit Function
    
    With rg.Columns(ColumnNumber)
        If rg.Rows.Count = 1 Then
            Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
            GetColumnRange = Data
        Else
            GetColumnRange = .Value
        End If
    End With

End Function