Excel VBA提取列唯一值：兼容Excel 2019及更早版本的方案

核心思路 #

用VBA的Scripting.Dictionary对象实现去重——字典的键天然具备唯一性，同时过滤空值，最后将结果写入目标位置，完全替代动态数组公式的功能。

完整VBA代码 #

Sub ExtractUniqueValues()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long
    Dim uniqueDict As Object
    Dim outputArr As Variant
    
    ' 绑定源表和目标表
    Set wsSource = ThisWorkbook.Worksheets("DataSheet")
    Set wsTarget = ThisWorkbook.Worksheets("Divide")
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' 动态获取源表C列最后一行的行号
    lastRow = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row
    
    ' 遍历源数据，过滤空值并收集唯一值
    For i = 2 To lastRow ' 从第2行开始，跳过表头
        If wsSource.Cells(i, "C").Value <> "" Then
            uniqueDict(wsSource.Cells(i, "C").Value) = Empty
        End If
    Next i
    
    ' 将结果写入目标表第16列（P列）
    If uniqueDict.Count > 0 Then
        outputArr = Application.Transpose(uniqueDict.Keys)
        wsTarget.Cells(2, 16).Resize(UBound(outputArr, 1), 1).Value = outputArr
    Else
        ' 无有效数据时清空目标列旧内容
        wsTarget.Range("P2:P" & wsTarget.Cells(wsTarget.Rows.Count, 16).End(xlUp).Row).ClearContents
    End If
    
    ' 释放资源
    Set uniqueDict = Nothing
    Set wsSource = Nothing
    Set wsTarget = Nothing
End Sub

代码说明 #

• 动态行号：不再固定写死25000行，自动获取C列最后一行的有效数据行，避免遗漏或无效遍历。
• 高效去重：利用字典键的唯一性自动去重，比循环比对效率更高。
• 批量写入：将字典的键转置为垂直数组后一次性写入目标列，比逐行写入速度更快。
• 空值处理：如果源表C列没有非空数据，会自动清空目标列的旧内容，避免残留无效数据。

使用步骤 #

1. 按Alt + F11打开VBA编辑器。
2. 右键点击工程里的工作簿名称 → 插入 → 模块。
3. 把代码粘贴到模块中，按F5运行，或者在Excel界面通过「开发工具」→「宏」选择ExtractUniqueValues执行。

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