VBA：“运行时错误‘457’：此键已与此集合的元素相关联”

问题描述

我在编写用于比较多个工作表（同一 Excel 文件）中的多列的宏时遇到问题。我写的很少，但它们花费的时间太长以至于 excel 崩溃了。

假设我在同一个文件中有 4 张纸。 Sheet1 有两列（B 和 C）和 7000 行。 Sheet2 空工作表新条目。 Sheet3 旧条目的空表，但有一些更新的值/信息。 Sheet4 是一个有 2 列（A 和 B）和 22000 行的数据库。

我需要将 Sheet1 中的 A 列与 Sheet4 中的 B 列进行比较。如果在 A 列 sheet1 中有全新的条目，则将该条目从 A 列 sheet1（及其从 B 列 sheet1 中的相应值）复制到 Sheet2 中的新行（A 列和 B 列）。如果 A 列 Sheet1 中的条目已经在 A 列 sheet4 中，则比较它们各自的 B 列值。如果工作表 1 中的 A 列 + B 列组合在工作表 4 中，则忽略它。如果 A 列 Sheet1 中的值在 A 列 Sheet4 中，但它们各自的 B 列值不匹配，则将 Sheet1 中的 A 列 + B 列复制到 Sheet3 中的新行（A 列和 B 列）。

我希望它足够清楚。由于行数问题（Sheet1 中的 7000 行与 Sheet4 中的 20000 行进行比较），我无法编写一个宏来处理一分钟内的所有内容。

有什么帮助吗？

编辑 1：我使用了@FaneDuru 建议的代码（谢谢！）。但我遇到了一个错误：“运行时错误‘457’：此键已与此集合的元素相关联” 是不是因为我在同一列中有很多重复值？

编辑 2：似乎 VBA 无法识别“if not dict3.exists”代码。当我用较小的字母输入“.exists”并跳转到另一行时，应该将其更正为大写的“.Exists”，对吗？它没有这样做。

编辑 3：我进行了更多测试。我正在休息并运行代码。当我在“If WorksheetFunction.CountIf(rngA4,arr1(i,1)) > 0 Then”这一行上打断时，不会发生错误。当我将中断放在“For j = UBound(arr4) To 1 Step -1”下面的一行时，错误正在发生。

错误是：“运行时错误‘457’：此键已与此集合的元素关联”

Private Sub CommandButton1_Click()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.displayStatusBar = False
Application.EnableEvents = False
Application.displayAlerts = False

Dim arr1,arr2,arr3,arr4,dict2 As Object,dict3 As Object,rngA4 As Range
Dim rngB4 As Range,i As Long,j As Long,lastR1 As Long,lastR4 As Long

lastR1 = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
lastR4 = Sheet4.Range("A" & Sheet4.Rows.Count).End(xlUp).Row

Set rngA4 = Sheet4.Range("A2:A" & lastR4)
Set rngB4 = Sheet4.Range("B2:B" & lastR4)

arr1 = Sheet1.Range("B2:C" & lastR1).Value
arr4 = Sheet4.Range("A2:B" & lastR4).Value

Set dict2 = CreateObject("Scripting.Dictionary")
Set dict3 = CreateObject("Scripting.Dictionary")

For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4,1)) = 0 Then
        dict2.Add arr1(i,1),2):
    End If
    If WorksheetFunction.CountIf(rngA4,1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i,1) = arr4(j,1) Then
                If arr1(i,2) <> arr4(j,2) Then
                    If arr1(i,2) Then
                        dict3.Add arr1(i,2): Exit For
                End If
            End If
        Next j
    End If
Next i

If dict2.Count > 0 Then
    arr2 = Application.Transpose(Array(dict2.keys,dict2.Items))
    Sheet2.Range("A2").Resize(dict2.Count,2).Value = arr2
End If

If dict3.Count > 0 Then
    arr3 = Application.Transpose(Array(dict3.keys,dict3.Items))
    Sheet3.Range("A2").Resize(dict3.Count,2).Value = arr3
End If

MsgBox "Done!"

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.displayStatusBar = True
Application.EnableEvents = True
Application.displayAlerts = True

End Sub

解决方法

您可以使用 Excel 公式 countif 查找数据集中不存在的任何数据条目。

然后您可以使用 Sheets().Range().Value = Sheets().Range().Value 在您想要输出的工作表中复制该值。如果输出范围已填充，您可以使用 Sheets().Range().End(xlDown).Address 查找输出数据集最后一行的地址。

您遍历每个返回 0 的 countif 值以获取所有缺失的数据。

请测试下一个代码。您没有回答澄清问题，并且代码假定出现的次数不超过一次，并且通过添加行来加载已处理的工作表。代码独立于这方面工作，但如果上述假设正确，它会运行得更快：

Sub testProcessNewEntries()
 Dim sh1 As Worksheet,sh2 As Worksheet,sh3 As Worksheet,sh4 As Worksheet
 Dim arr1,arr2,arr3,arr4,dict2 As Object,dict3 As Object,rngA4 As Range
 Dim rngB4 As Range,i As Long,j As Long,lastR1 As Long,lastR4 As Long
 
 Set sh1 = Worksheets("Sheet1") 'use here your first sheet
 Set sh2 = Worksheets("Sheet2") 'use here your second sheet
 Set sh3 = Worksheets("Sheet3") 'use here your third sheet
 Set sh4 = Worksheets("Sheet4") 'use here your fourth sheet
 
 lastR1 = sh1.Range("A" & sh1.Rows.count).End(xlUp).row
 lastR4 = sh4.Range("A" & sh4.Rows.count).End(xlUp).row
  
 Set rngA4 = sh4.Range("A2:A" & lastR4)
 Set rngB4 = sh4.Range("B2:B" & lastR4)
 
 arr1 = sh1.Range("A2:B" & lastR1).Value
 arr4 = sh4.Range("A2:B" & lastR4).Value
 
 Set dict2 = CreateObject("Scripting.Dictionary")
 Set dict3 = CreateObject("Scripting.Dictionary")
 
 For i = UBound(arr1) To 1 Step -1
    If WorksheetFunction.CountIf(rngB4,arr1(i,1)) = 0 Then
        dict2.Add arr1(i,1),2):
    End If
    If WorksheetFunction.CountIf(rngA4,1)) > 0 Then
        For j = UBound(arr4) To 1 Step -1
            If arr1(i,1) = arr4(j,1) Then
                If arr1(i,2) <> arr4(j,2) Then
                    If Not dict3.Exists(arr1(i,1)) Then
                        dict3.Add arr1(i,2): Exit For
                    End If
                End If
            End If
        Next j
    End If
 Next i
 
 If dict2.count > 0 Then
    arr2 = Application.Transpose(Array(dict2.Keys,dict2.Items))
    sh2.Range("A2").Resize(dict2.count,2).Value = arr2
 End If
 If dict3.count > 0 Then
    arr3 = Application.Transpose(Array(dict3.Keys,dict3.Items))
    sh3.Range("A2").Resize(dict3.count,2).Value = arr3
 End If
 MsgBox "Ready..."
End Sub

vba vba6 vba7