根据2个条件搜索表，并操作并向新列添加条目

Question

我有一个数据列表，我想根据列表的旧版本添加注释，这是同一工作簿中的另一个工作表。

现在我尝试了一个带有两个循环的方法（第一个实际查看给定行中是否有注释，然后第二个在新工作表的每一行中查找标准并在必要时添加注释）但是它结果太慢了。每张表中有大约15 000个条目，大约6500个条目在旧表中有注释。

我需要一种更快捷的方式来将旧表格中的注释添加到新工作表中。如您所见，较旧工作表中的某些标准组合可能在较新的工作表中具有多个相应的组合。在这种情况下，我需要符合条件的所有行中的注释。

Answer 1

在收集评论ID列表时，使用Scripting.Dictionary对象标识前两列的唯一列表。

Option Explicit

Sub copyCommentIDs()
    Dim a As Long, b As Long, aCOMs As Variant, k As Variant
    Dim d As Long, dCOMs As Object

    Set dCOMs = CreateObject("Scripting.Dictionary")
    dCOMs.comparemode = vbTextCompare

    With Worksheets("Sheet19")
        'collect data from Old Sheet into an array
        aCOMs = .Range(.Cells(3, "E"), .Cells(.Rows.Count, "G").End(xlUp)).Value2
    End With

    'build dictionary; collect comment IDs
    For a = LBound(aCOMs, 1) To UBound(aCOMs, 1)
        'if there a comment ID?
        If CBool(Len(Trim(aCOMs(a, 3)))) Then
            'concatenate/deliminate the first two columns
            k = Join(Array(aCOMs(a, 1), aCOMs(a, 2)), ChrW(8203))
            'does it exist in the dictionary?
            If dCOMs.exists(k) Then
                'it exists; concatenate the comment id onto the dict. key's item
                dCOMs.Item(k) = Join(Array(dCOMs.Item(k), aCOMs(a, 3)), ", ")
            Else
                'does not exist; add a new dict key/item pair
                dCOMs.Item(k) = aCOMs(a, 3)
            End If
        End If
    Next a

    With Worksheets("Sheet19")
        'return the dictionay items to the new sheet
        For b = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
            'concatenate/deliminate the first two columns
            k = Join(Array(.Cells(b, "A").Value2, .Cells(b, "B").Value2), ChrW(8203))
            'does it exist in the dictionary?
            If dCOMs.exists(k) Then
                'transfer the comment id
                .Cells(b, "C") = dCOMs.Item(k)
            End If
        Next b
    End With

    'clean up
    Erase aCOMs
    dCOMs.RemoveAll: Set dCOMs = Nothing
End Sub