I want to select the unique Key Value pair from the 2 different whole column and insert the data into "Scripting.Dictionary" using VBA Code. I have used before List() but I need the key value pair for search and replace the string by loop through later on. Column length not fixed.
Dictionary should be (Key, Value ) as (DeviceGuid, SerialNo).
My data as below :
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
