如何使用 Excel VBA 宏将集合键值对合并为一组键值对？

Question

我有一个电子表格，其中包含一些键值对，但在一个集合中，例如如下所示（键值的顺序不固定）：

Key     Value     Key    Value    Key    Value
ABC     999       JKL     888     MNO    777
DEF     555       RST     666     XYZ    444
AAA     123                       NNN    333

我正在使用包含对键的描述的映射表，并使用该键尝试在单独的表中打印描述旁边的值。

我的映射表如下所示：

SNo   Key    Description
1     ABC     Test1
2     JKL     Test2
3     MNO     Test3
4     DEF     Test4
5     RST     Test5
6     XYZ     Test6
7     AAA     Test7
8     BBB     Test8
9     CCC     Test9
...   ....    .....
14    NNN     Test14

在输出中，我试图在我的输入表中显示它们的 SNo 和描述旁边的那些键。这是我正在努力获得的预期输出。

SNo     Description     Value
 1      Test1           999
 2      Test2           888
 3      Test3           777
 4      Test4           555
 5      Test5           666
 6      Test6           444
 7      Test7           123
14      Test14          333

如何在 excel 宏中实现这一点？

我有一个函数，用于根据所选工作表中的单元格地址获取值，然后将其存储在变量中并将其传递给输出。但这是逐个单元的方法，执行时间太长。

这是我用来根据单元格地址获取值的示例函数，该单元格地址当前需要操作列和行索引以查找值并给我可以用来带来单元格值的单元格地址：

Function getAddress(ByVal colValue As String, ByVal rowValue As String) As Range
Dim row, col As Variant

With ActiveSheet
    row = Application.Match(rowValue, .Columns("B"), 0)  'To lookup for key in the mapping sheet but need to be changed based on the sheet the function is doing a lookup in
    col = Application.Match(colValue, .Rows(1), 0)
    
    If IsError(r) Then
        row = 0
        col = 0
    End If
    Set getAddress = .Cells(row, col)
    
End With
End Function

我确信存在更好的方法，但在过去的几个月里我一直在探索 VBA，并在旅途中学习它。提前感谢任何帮助。

Answer 1

为此，您可以使用 Dictionary 对象：

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

之前：

之后：

Answer 2

写入唯一值

来源 (Sheet1)

查找、地图 (Sheet2)

目标、结果 (Sheet3)

• 调整常量部分中的值。
• 您只运行WriteUnique（适当地重命名它）。伴随的函数由它调用。

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