VBA中删除数组中间匹配元素并合并差异元素至目标数组

原代码的问题 #

你的这段Dictionary实现存在多处问题，无法正确完成需求：

• 循环依赖dict1.Count，但删除元素会改变字典的元素数量，导致后续索引越界或漏处理元素。比如删除一个元素后，原i对应的键/值可能已不存在，继续循环会触发错误。
• 嵌套循环完全浪费了Dictionary的快速查找优势，效率和数组嵌套循环没有区别，失去了使用Dictionary的意义。
• On Error Resume Next会掩盖所有错误，比如删除后访问dict1.Keys()(i)触发的下标越界错误，代码会悄悄执行错误逻辑而不提示。
• 仅处理了删除dict1中的匹配项，未完成「将Arr1剩余元素添加到Arr2」的核心需求。

最优实现方案（基于数组+Dictionary快速查找） #

下面是完整实现需求的高效代码，利用Dictionary的O(1)查找特性，避免嵌套循环：

Public Sub ProcessArrays()
    Dim arr1 As Variant, arr2 As Variant
    Dim dict2 As Object
    Dim tempArr As Variant
    Dim i As Long, tempIndex As Long
    
    ' 假设arr1和arr2已完成赋值，例如：
    ' arr1 = Array("苹果", "香蕉", "橙子", "葡萄")
    ' arr2 = Array("香蕉", "葡萄", "西瓜")
    Set dict2 = CreateObject("Scripting.Dictionary")
    
    ' 1. 将Arr2的元素存入字典，用于快速查重
    For i = LBound(arr2) To UBound(arr2)
        If Not dict2.Exists(arr2(i)) Then
            dict2.Add arr2(i), True ' 值仅作占位，核心是用键存储Arr2元素
        End If
    Next i
    
    ' 2. 筛选Arr1中不在Arr2的元素，同时收集这些元素
    ReDim tempArr(0 To UBound(arr1))
    tempIndex = 0
    For i = LBound(arr1) To UBound(arr1)
        If Not dict2.Exists(arr1(i)) Then
            tempArr(tempIndex) = arr1(i)
            tempIndex = tempIndex + 1
        End If
    Next i
    
    ' 更新Arr1为筛选后的剩余元素
    If tempIndex > 0 Then
        ReDim Preserve tempArr(0 To tempIndex - 1)
        arr1 = tempArr
    Else
        arr1 = Array() ' 若Arr1元素全匹配，则设为空数组
    End If
    
    ' 3. 将Arr1剩余元素添加到Arr2
    If tempIndex > 0 Then
        ReDim Preserve arr2(LBound(arr2) To UBound(arr2) + tempIndex)
        For i = 0 To tempIndex - 1
            arr2(UBound(arr2) - tempIndex + 1 + i) = tempArr(i)
        Next i
    End If
    
    Set dict2 = Nothing
End Sub

方案优势 #

• 仅用两次单循环，效率远高于嵌套循环，元素越多优势越明显。
• 逻辑清晰，先筛选再更新数组，避免了直接删除元素导致的索引混乱。
• 完整实现需求的两个核心步骤：删除Arr1的匹配项、将剩余元素添加到Arr2。

若需保留Dictionary结构的正确实现 #

如果必须用Dictionary来处理（而非数组），需先将字典的键存入数组再遍历，避免删除元素导致的索引问题：

Public Sub CorrectDictProcess()
    Dim dict1 As Object, dict2 As Object
    Dim keysArr As Variant
    Dim i As Long
    
    Set dict1 = CreateObject("Scripting.Dictionary")
    Set dict2 = CreateObject("Scripting.Dictionary")
    
    ' 假设dict1和dict2已完成元素填充
    ' 1. 将dict1的键存入数组，避免删除时索引错乱
    keysArr = dict1.Keys
    
    ' 2. 删除dict1中与dict2匹配的元素
    For i = LBound(keysArr) To UBound(keysArr)
        If dict2.Exists(dict1(keysArr(i))) Then
            dict1.Remove keysArr(i)
        End If
    Next i
    
    ' 3. 将dict1剩余元素添加到dict2
    For Each key In dict1.Keys
        If Not dict2.Exists(dict1(key)) Then
            dict2.Add dict1(key), True ' 可根据需求调整键值对存储逻辑
        End If
    Next key
    
    Set dict1 = Nothing
    Set dict2 = Nothing
End Sub

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