Excel VBA宏报错求助：跨工作簿列匹配复制数据失败

错误原因 #

报错this key is already associated with an item in this collection是因为W1的B列存在重复值，而Scripting.Dictionary的.Add方法不允许添加重复键，触发了字典的唯一性约束。

修复后的单工作表版本代码 #

Sub find_and_copy()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r As Range
    Dim dict As Object
    
    Set ws1 = ThisWorkbook.Sheets(1)
    Set ws2 = Workbooks("Classeur1").Sheets(1)
    Set dict = CreateObject("Scripting.Dictionary")
    
    dict.CompareMode = vbTextCompare
    
    ' 遍历W1的B列，用.Item赋值避免重复键报错（重复键会覆盖最后一次出现的行号）
    For Each r In ws1.Range("B2", ws1.Range("B" & ws1.Rows.Count).End(xlUp))
        If Not IsEmpty(r) Then dict(r.Value) = r.Row
    Next r
    
    ' 遍历W2的B列，匹配后复制D列到W1的E列
    For Each r In ws2.Range("B2", ws2.Range("B" & ws2.Rows.Count).End(xlUp))
        If dict.Exists(r.Value) Then
            ' 仅复制D列内容到W1对应行的E列，而非整行
            ws1.Range("E" & dict(r.Value)).Value = ws2.Range("D" & r.Row).Value
        End If
    Next r
    
    ' 释放对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

关键修复点 #

• 替换.Add方法为dict(r.Value) = r.Row：字典的.Item属性赋值时，若键已存在会直接覆盖原有值，不会抛出重复键错误（若需保留所有重复行的匹配，可改用集合存储行号列表，此版本默认保留最后一次出现的行号）。
• 修正复制逻辑：原代码复制整行，现在改为仅复制W2当前行的D列值到W1对应行的E列，符合需求。
• 明确指定ws1.Rows.Count：避免跨工作表引用Rows.Count时的潜在范围错误。

扩展到W2所有工作表的版本 #

如果需要遍历W2的所有工作表，在外层添加工作表循环即可：

Sub find_and_copy_all_sheets()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r As Range
    Dim dict As Object
    
    Set ws1 = ThisWorkbook.Sheets(1)
    Set dict = CreateObject("Scripting.Dictionary")
    
    dict.CompareMode = vbTextCompare
    
    ' 构建W1的B列值-行号映射
    For Each r In ws1.Range("B2", ws1.Range("B" & ws1.Rows.Count).End(xlUp))
        If Not IsEmpty(r) Then dict(r.Value) = r.Row
    Next r
    
    ' 遍历W2的所有工作表
    For Each ws2 In Workbooks("Classeur1").Worksheets
        For Each r In ws2.Range("B2", ws2.Range("B" & ws2.Rows.Count).End(xlUp))
            If dict.Exists(r.Value) Then
                ws1.Range("E" & dict(r.Value)).Value = ws2.Range("D" & r.Row).Value
                ' 若需要保留所有匹配值（而非覆盖），可改为：
                ' ws1.Range("E" & dict(r.Value)).Value = ws1.Range("E" & dict(r.Value)).Value & ", " & ws2.Range("D" & r.Row).Value
            End If
        Next r
    Next ws2
    
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

内容的提问来源于stack exchange，提问作者Satanas