2つの条件に基づいてテーブルを検索し、新しい列に操作を加えてエントリを追加します。

Question

同じブックの別のワークシートである古いバージョンのリストに基づいてコメントを追加したいデータリストがあります。

私は2つのループを使ってアプローチを試みました。最初は、特定の行にコメントがあるかどうかを調べて、次に新しいシートのすべての行に基準を探し、必要に応じてコメントを追加します）しかしそれはあまりにも遅くなった。各シートには約15,000のエントリがあり、古いシートにはコメントがある約6500のエントリがあります。

古いシートから新しいシートにコメントを追加するには、より早い方法が必要です。ご覧のように、古いシートの基準の特定の組み合わせには、新しいシートに複数の対応する組み合わせがある場合があります。その場合、基準に合うすべての行にコメントが必要です。

Answer 1

Scripting.Dictionaryオブジェクトを使用して、最初の2つの列の一意のリストを識別し、コメントIDのリストを収集します。

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