How to merge sets key value pairs into single set of key value pair using Excel VBA Macro?

To do this, you can use the Dictionary object:

Option Explicit

Sub MergeSets()
    ' set a reference to 'Microsoft Scripting Runtime' in Tools->References VBE menu
    Dim dict As New Dictionary
    Dim src As Variant, out As Variant
    Dim r As Long, c As Long, cnt As Long, key As String
    
    With ThisWorkbook.Worksheets(1)
        ' get the data from the first range (without header) into the src array in one read operation
        src = Intersect(.Range("A1").CurrentRegion, .Range("A1").CurrentRegion.Offset(1))
        ' make the dictionary
        For r = 1 To UBound(src, 1)
            For c = 1 To UBound(src, 2) Step 2
                key = Trim(CStr(src(r, c)))
                If Len(key) > 0 And Not dict.Exists(key) Then dict.Add key, src(r, c + 1)
            Next
        Next
        
        ' get the data from the second range (without header) into the src array in one read operation
        src = Intersect(.Range("H1").CurrentRegion, .Range("H1").CurrentRegion.Offset(1))
        ' prepare array for output
        ReDim out(1 To 3, 1 To UBound(src, 1))
        cnt = 0
        ' iterate the data from the second range
        For r = 1 To UBound(src, 1)
            key = Trim(CStr(src(r, 2)))
            ' match the data from the second range with the dictionary keys
            If Len(key) > 0 And dict.Exists(key) Then
                cnt = cnt + 1
                out(1, cnt) = src(r, 1) ' number
                out(2, cnt) = src(r, 3) ' Description
                out(3, cnt) = dict(key) ' value for key
            End If
        Next
        
        ' we can change only the last dimenshion of the array
        ReDim Preserve out(1 To 3, 1 To cnt)
        ' Transpose the out array to output
        out = WorksheetFunction.Transpose(out)
        
        ' output the result
        .Range("L2").Resize(cnt, 3).Value = out
    End With
End Sub

Before:

After:

Write Unique Values

Source (Sheet1)

Lookup, Map (Sheet2)

Destination, Result (Sheet3)

• Adjust the values in the constants section.
• You only run WriteUnique (rename it appropriately). The accompanying functions are called by it.

Option Explicit

Sub WriteUnique()
    
    ' Define constants.
    
    Const sName As String = "Sheet1"
    Const sfRow As Long = 1
    Const sTitle As String = "Key"
    
    Const lName As String = "Sheet2"
    Const lFirst As String = "B2"
    
    Const dName As String = "Sheet3"
    Const dFirst As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the unique values from the Source Ranges to a Dictionary.
    ' It is assumed that the keys are in all columns where the cell value
    ' in row 'sfRow' is equal to 'sTitle'.
    ' It is assumed that the values are in the cells to the right of the keys.
    ' e.g. Key | Any | | Key | Value | Key | Any2 | | Key | |
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim Key As Variant
    Dim r As Long
    
    With sws.Rows(sfRow)
        Dim fCell As Range
        Set fCell = .Find(sTitle, .Cells(.Columns.Count), xlFormulas, xlWhole)
        If Not fCell Is Nothing Then
            Dim FirstAddress As String: FirstAddress = fCell.Address
            Dim srg As Range
            Dim sData As Variant: ReDim sData(1 To 2)
            Do
                Set srg = Nothing
                Set srg = refColumn(fCell.Offset(1))
                If Not srg Is Nothing Then
                    sData(1) = getColumn(srg)
                    sData(2) = getColumn(srg.Offset(, 1))
                    For r = 1 To UBound(sData(1), 1)
                        Key = sData(1)(r, 1)
                        If Not IsError(Key) Then
                            If Len(Key) > 0 Then
                                If Not dict.Exists(Key) Then
                                    dict.Add Key, sData(2)(r, 1)
                                End If
                            End If
                        End If
                    Next r
                End If
                Set fCell = .Find(sTitle, fCell, xlFormulas, xlWhole)
            Loop Until fCell.Address = FirstAddress
        End If
    End With
    
    ' Write the values from the Lookup Range to the Lookup Data Array.
    ' SNo | Key | Description

    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lrg As Range: Set lrg = refColumn(lws.Range(lFirst))
    
    Dim lData As Variant: ReDim lData(1 To 3)
    lData(1) = getColumn(lrg.Offset(, -1))
    lData(2) = getColumn(lrg)
    lData(3) = getColumn(lrg.Offset(, 1))
    
    ' Write the values from the Lookup Data Array and the Dictionary
    ' to the (resulting) Destination Data Array.
    
    Dim dData As Variant: ReDim dData(1 To UBound(lData(1), 1), 1 To 3)
    Dim n As Long
    For r = 1 To UBound(lData(2), 1)
        Key = lData(2)(r, 1)
        If dict.Exists(Key) Then
            n = n + 1
            dData(n, 1) = lData(1)(r, 1)
            dData(n, 2) = lData(3)(r, 1)
            dData(n, 3) = dict(Key)
        End If
    Next r
    
    ' Write the values from the Destination Data Array to the Destination Range.
    ' It is assumed that the headers (titles) are already written e.g.:
    ' SNo | Description | Value

    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dCell As Range: Set dCell = dws.Range(dFirst)
    Dim drg As Range: Set drg = dCell.Resize(n, 3)
    drg.Value = dData
    
    ' Clear the contents below the Destination Range.
    
    Dim dcrg As Range
    Set dcrg = dCell.Resize(dws.Rows.Count - dCell.Row - n + 1, 3).Offset(n)
    dcrg.ClearContents
        
End Sub


Function refColumn( _
    FirstCellRange As Range, _
    Optional ByVal NonBlankInsteadOfNonEmpty As Boolean = False) _
As Range
    Const ProcName As String = "refColumn"
    On Error GoTo clearError
    
    If Not FirstCellRange Is Nothing Then
        With FirstCellRange.Cells(1)
            Dim cLookIn As XlFindLookIn
            If NonBlankInsteadOfNonEmpty Then
                cLookIn = xlValues
            Else
                cLookIn = xlFormulas
            End If
            Dim cel As Range
            Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , cLookIn, , , xlPrevious)
            If Not cel Is Nothing Then
                Set refColumn = .Resize(cel.Row - .Row + 1)
            End If
        End With
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function


Function getColumn( _
    rg As Range, _
    Optional ByVal ColumnNumber As Long = 1, _
    Optional ByVal doTranspose As Boolean = False) _
As Variant
    Const ProcName As String = "getColumn"
    On Error GoTo clearError
    
    If Not rg Is Nothing Then
        If ColumnNumber > 0 And ColumnNumber <= rg.Columns.Count Then
            With rg.Columns(ColumnNumber)
                Dim rCount As Long: rCount = rg.Rows.Count
                Dim Result As Variant
                If rCount > 1 Then
                    If doTranspose Then
                        Dim Data As Variant: Data = .Value
                        ReDim Result(1 To 1, 1 To rCount)
                        Dim r As Long
                        For r = 1 To rCount
                            Result(1, r) = Data(r, 1)
                        Next r
                        getColumn = Result
                    Else
                        getColumn = .Value
                    End If
                Else
                    ReDim Result(1 To 1, 1 To 1): Result(1, 1) = .Value
                    getColumn = Result
                End If
            End With
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function