☰

Excel - 在一列中查找唯一值并从另一列中查找相应的值

tag-icon • tag-icon microsoft-excel worksheet-function vba sorting
Excel - 在一列中查找唯一值并从另一列中查找相应的值

我有一个包含两列组件和标签的数据库导出。A 列包含一个组件，B 列包含与该组件相关的标签。同一个组件可以在 A 列中多次显示，但带有一组不同的标签。

我需要在单元格 D 中创建一个唯一的组件列表，并在 E 列中组件旁边的单元格中列出每个相关标签。

我知道如何在 A 列中创建唯一的值列表，但不知道如何在同一个单元格中出现多个值时分隔这些值。我无法更改数据库导出这些数据的方式。

如果这是唯一的方法，我对 VBA 有足够的了解，可以为此创建一个宏。任何帮助都将不胜感激。

这是我需要做的：

这是我需要做的

答案1

您可以通过制作二维字典来实现这一点。我建议使用字典，因为它可以解决唯一性问题。我编写了一个宏来执行此任务（至少针对您的示例数据）。它首先设置二维数据结构，然后按字母顺序打印出来。它包括我在这里找到的排序函数的简化版本：https://exceloffthegrid.com/sorting-an-array-alphabetically-with-vba/

在我的宏中，数据从第 1 行 ( ) 读取For i = 1 To Cells(Row.Count...到包含数据的最后一行。如有必要，请进行调整。您可能还设置了正确的列字母（只需搜索 ActiveSheet.Range 即可看到）。

请注意，排序函数按字母顺序排序，因此标签 11 将排在标签 2 之前。如果这是个问题，我认为最快的方法是为标签数组创建第二个排序函数，该函数在比较之前将标签转换为数字。我知道，我知道这会带来糟糕的性能，但希望这没关系 :)

首先，宏读取所有输入行并用 , 字符将它们拆分（删除前面的空格 - 如果组件和标签始终用逗号和空格分隔，则可以简化）。对于每个组件，它都会创建一个子字典，其中存储标签并填充它们。如果组件出现多次，则更新现有字典。这是第一个主 For 循环。如果设置了数据，它会打印出按 D 列和 E 列排序的数据。这是第二个主 For Each 循环。

最后是代码（我把它放在工作簿部分，而不是在工作表的代码模块中，但也可以在那里使用）：

Sub CollectLabels()
    Dim spl() As String
    Dim dict
    Dim subDict
    Dim lbl As String

    ' Collect data into a 2-dimensional dictionary
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        comps = Split(Replace(ActiveSheet.Range("A" & i).Text, " ", ""), ",")
        For Each comp In comps
            If Not dict.Exists(comp) Then
                Set subDict = CreateObject("Scripting.Dictionary")
                dict.Add comp, subDict
            End If
            Labels = Split(Replace(ActiveSheet.Range("B" & i).Text, " ", ""), ",")
            For Each Label In Labels
                dict(comp)(Label) = 1
            Next Label
        Next comp
    Next i

    i = 1
    ' Output the dictionary contents
    For Each Key In SortArray(dict.Keys)
        ActiveSheet.Range("D" & i).Value = Key
        lbl = ""
        For Each Key2 In SortArray(dict(Key).Keys)
            lbl = lbl & Key2 & ", "
        Next Key2
        ActiveSheet.Range("E" & i).Value = lbl
        i = i + 1
    Next Key
End Sub

Function SortArray(arr As Variant)

Dim i As Long
Dim j As Long
Dim Temp

For i = LBound(arr) To UBound(arr) - 1
    For j = i + 1 To UBound(arr)
        If arr(i) > arr(j) Then
            Temp = arr(j)
            arr(j) = arr(i)
            arr(i) = Temp
        End If
    Next j
Next i

SortArray = arr

End Function

相关内容