Question

我有一个产品列表，每个产品都有自己的关键字，可用于在网站上搜索该产品。我想生成一个唯一关键字列表和可以为每个唯一关键字找到的产品列表。

来源示例

Products    Keywords
--------    --------
Envelope1   1,envelope
Envelope2   2,envelope
Label1      label,mailing
label2      label,mailing
label3      label,mailing,address

我想要的生成列表看起来像......

Keywords   Products
--------   --------
1          Envelope1
2          Envelope2
envelope   Envelope1,Envelope2
label      label1,label2,label3
mailing    label1,label2,label3
address    label3

然后我会遍历关键字并获取该关键字的产品，执行搜索，然后验证是否找到了所有产品。

我可以创建一个包含唯一关键字列表的集合，但我正在努力研究如何创建相关的产品列表。我想我想使用嵌套集合，如here所述，但我很难弄清楚细节，因为我正在尝试添加到动态列表中。

' loop through each cell in the keywords column, ignoring the column header
For i = 2 To maxRow
    ' the keywords are comma delimited so they must be Split()
    k = Split(ActiveSheet.Cells(i, keywordColumn).Value, ",")
    For j = 0 To UBound(k)
        ' turn off error checking to trap Error 457
        On Error Resume Next
        keywords.Add Item:=k(j), Key:=k(j)
        errNumber = CLng(Err.Number)
        On Error GoTo 0

        ' trap Error 457, the key already exists in the collection
        ' then ... do something to associate the product with the keyword
        If errNumber = 457 Then
            keywords.Item(k(j)).Add productCode???
        End If
    Next j
Next i

我并不依赖于这种方法，所以如果有更好的方法可以做到这一点......我很好。在此先感谢您的帮助。

Answer 1

您可以使用Dictionary对象：

Sub test()
    Dim keywordColumn As String, productColumn As String
    Dim products As String
    Dim i As Integer
    Dim myKey, p

    'after adding reference to Microsoft Scripting Runtime
    'Dim Keywords As New Dictionary

    Dim Keywords As Object
    Set Keywords = CreateObject("Scripting.Dictionary")

    keywordColumn = "B"
    productColumn = "A"

    With ActiveSheet
        maxRow = .Cells(.Rows.Count, productColumn).End(xlUp).Row
        ' loop through each cell in the keywords column, ignoring the column header
        For i = 2 To maxRow
            ' the keywords are comma delimited so they must be Split()
            k = Split(.Cells(i, keywordColumn).Value, ",")

            For Each myKey In k
                If Not Keywords.Exists(myKey) Then
                    Keywords.Add key:=myKey, Item:=New Collection
                End If

                With .Cells(i, productColumn)
                    On Error Resume Next
                    Keywords(myKey).Add Item:=.Value, key:=CStr(.Value)
                    On Error GoTo 0
                End With                                        
            Next myKey
        Next i

        '**********************************************
        'OUTPUT
        '**********************************************

        i = 2
        'iterates through each key
        For Each myKey In Keywords.Keys                
            products = ""
            'iterates through each product corresponding to myKey 
            For Each p In Keywords(myKey)
                products = products & p & ", "
            Next
            'write in cells
            .Cells(i, "D") = myKey
            If products <> "" Then .Cells(i, "E") = Left(products, Len(products) - 2)

            i = i + 1
        Next

    End With
End Sub

<强>结果：

enter image description here

注意：我建议您添加对 Microsoft Scripting Runtime 库的引用（转到工具 - ＆gt;参考并选择< em> Microsoft Scripting Runtime ）。在这种情况下，您可以使用：

Dim Keywords As New Dictionary

而不是

Dim Keywords As Object
Set Keywords = CreateObject("Scripting.Dictionary")

引用库可以加快代码速度，并为Keywords对象添加智能功能。

Answer 2

我用于类似项目的算法是这样的

Array1：用于存储关键字的1D数组。没有重复

Array2：2D数组。行等于Array1。在每一行中都会有一系列与关键字相关联的产品。

步骤1：您将循环遍历所有关键字并填充Array1

步骤2：您将双重循环关键字和产品并填充Array2。

创建与VBA中唯一搜索关键字列表关联的产品的动态列表

2 个答案: