VBA实现两工作表多条件匹配赋值且避免重复数据的问题求助

核心思路 #

放弃嵌套循环逐行比对的低效逻辑，改用数组批量读写数据+字典分组存储符合条件的Sheet2记录模式，既大幅提升运行效率，又严格保证Sheet2的A列值不重复使用。

具体VBA代码实现 #

Sub AssignUniqueLocation()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim arr1 As Variant, arr2 As Variant
    Dim dict As Object
    Dim i As Long
    Dim key As String
    Dim tempList As Collection
    
    ' 指定工作表
    Set ws1 = ThisWorkbook.Worksheets("Mass Slot List")
    Set ws2 = ThisWorkbook.Worksheets("Location Storage Types")
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 批量读取Sheet2全量数据到数组（避免反复读写单元格）
    arr2 = ws2.Range("A1:E" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 遍历Sheet2，按条件分组存入字典
    For i = LBound(arr2, 1) To UBound(arr2, 1)
        ' 筛选符合要求的行：C列=L、D列=No
        If arr2(i, 3) = "L" And arr2(i, 4) = "No" Then
            ' 生成分组键：Sheet2.B列编码 + Sheet2.E列值（对应Sheet1.A列）
            key = arr2(i, 2) & "|" & arr2(i, 5)
            ' 键不存在则创建新集合
            If Not dict.Exists(key) Then
                Set dict(key) = New Collection
            End If
            ' 将Sheet2.A列值加入对应分组集合
            dict(key).Add arr2(i, 1)
        End If
    Next i
    
    ' 批量读取Sheet1需要的列到数组：A列、C列、AQ列
    arr1 = ws1.Range("A1:C" & ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row & ",AQ:AQ").Value
    
    ' 遍历Sheet1，分配唯一匹配值
    For i = LBound(arr1, 1) To UBound(arr1, 1)
        key = arr1(i, 3) & "|" & arr1(i, 1)
        ' 检查对应分组是否有可用值
        If dict.Exists(key) And dict(key).Count > 0 Then
            ' 取出第一个可用值并赋值给Sheet1.C列
            arr1(i, 2) = dict(key)(1)
            ' 移除已使用的值，避免重复分配
            dict(key).Remove 1
        End If
    Next i
    
    ' 批量将处理结果写回Sheet1.C列
    ws1.Range("C1:C" & UBound(arr1, 1)).Value = Application.Index(arr1, 0, 2)
    
    ' 释放对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    MsgBox "分配完成！"
End Sub

代码关键点说明 #

1. 数组批量读写：把工作表数据一次性读入数组，彻底避免嵌套循环中反复读写单元格的性能损耗（这是原代码导致Excel崩溃的核心原因）。
2. 字典分组存储：将Sheet2符合条件的记录按「编码+匹配值」分组，后续可直接通过键快速定位，无需逐行比对。
3. 唯一值保障：每次取出集合中的值后立即移除，确保Sheet2的A列值仅被使用一次。
4. 批量写入结果：处理完数组后一次性写回工作表，进一步减少Excel交互次数。

额外优化技巧 #

运行代码前可关闭Excel的屏幕更新和自动计算，进一步提升速度：

' 代码开头加入
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' 代码结尾恢复
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

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