从数据集提取唯一产品ID及对应列值至新工作表的VBA优化需求

针对7万多行、42列的大数据集，VLOOKUP因逐单元格查找导致效率极低，推荐使用「字典（Dictionary）+ 数组」的组合方案，通过减少单元格交互次数、利用字典O(1)的查找特性大幅提升运行速度。

修正后的高效代码 #

Sub UniqueProductDetails()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, i As Long, destRow As Long
    Dim sourceArr As Variant, destArr As Variant
    Dim uniqueDict As Object
    
    ' 关闭耗时的Excel功能，提升运行速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 初始化工作表对象（修正原代码的语法错误）
    Set wsSource = ThisWorkbook.Worksheets("Source")
    Set wsDest = ThisWorkbook.Worksheets("Destination")
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' 获取源数据最后一行，将所有数据批量读入数组（减少单元格交互开销）
    lastRow = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
    sourceArr = wsSource.Range("A1:" & wsSource.Cells(lastRow, 42)).Value ' 42为数据总列数
    
    ' 遍历数组，用字典存储唯一ID及对应整行数据
    For i = 1 To UBound(sourceArr)
        ' 以A列值为唯一Key，仅保留首次出现的行数据
        If Not uniqueDict.Exists(sourceArr(i, 1)) Then
            uniqueDict.Add sourceArr(i, 1), Application.Index(sourceArr, i, 0)
        End If
    Next i
    
    ' 将字典中的数据写入目标数组，再一次性写入工作表
    destRow = uniqueDict.Count
    If destRow > 0 Then
        ReDim destArr(1 To destRow, 1 To 42)
        i = 1
        For Each key In uniqueDict.Keys
            destArr(i, 1 To 42) = uniqueDict(key)
            i = i + 1
        Next key
        ' 清空目标表原有数据，批量写入结果
        wsDest.Cells.Clear
        wsDest.Range("A1").Resize(destRow, 42).Value = destArr
    End If
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 释放对象内存
    Set wsSource = Nothing
    Set wsDest = Nothing
    Set uniqueDict = Nothing
End Sub

核心优化点说明 #

• 数组批量读写：将源数据一次性读入内存数组，处理完成后再批量写入目标表，避免逐单元格操作的巨大性能损耗。
• 字典快速去重：利用Scripting.Dictionary的Key唯一性实现O(1)时间复杂度的去重，效率远高于VLOOKUP的逐行匹配。
• 临时关闭后台功能：关闭屏幕更新、事件触发和自动计算，减少运行过程中的资源占用。

可选调整 #

如果需要保留重复ID的最后一行数据，只需将字典添加逻辑改为：

uniqueDict(sourceArr(i, 1)) = Application.Index(sourceArr, i, 0)

（直接覆盖已存在的Key对应的Item即可）

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