Excel VBA：多列提取唯一值合并至单列（动态范围需求）

嘿，我完全懂你不想被固定范围束缚的需求！之前找到的AdvancedFilter代码确实好用，但硬写死范围太不灵活了。下面给你两个实用的VBA方案，都是基于动态数据范围来处理的，随便挑适合你的用～

方法一：用AdvancedFilter结合临时列（适合新手理解） #

这个方法先把多列数据合并到临时列，再用AdvancedFilter提取唯一值，逻辑直观：

Sub ExtractUniqueValuesFromMultipleColumns()
    Dim sourceWS As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim sourceRange As Range, tempRange As Range, uniqueRange As Range
    
    ' 替换成你的目标工作表名称
    Set sourceWS = ThisWorkbook.Worksheets("Sheet1")
    
    ' 动态获取数据的最后一行和最后一列
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row
    lastCol = sourceWS.Cells(1, sourceWS.Columns.Count).End(xlToLeft).Column
    
    ' 定义完整的源数据范围（从A1到数据区域的右下角）
    Set sourceRange = sourceWS.Range(sourceWS.Cells(1, 1), sourceWS.Cells(lastRow, lastCol))
    
    ' 选最后一列的下一列当临时存储区
    Set tempRange = sourceWS.Cells(1, lastCol + 1)
    
    ' 把多列数据转置合并到临时列
    sourceRange.Copy
    tempRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    
    ' 提取唯一值到B列（你可以改成自己需要的目标位置）
    sourceWS.Range(tempRange, tempRange.End(xlDown)).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=sourceWS.Range("B1"), _
        Unique:=True
    
    ' 清理临时列（可选，不想清理就删掉这行）
    sourceWS.Columns(lastCol + 1).ClearContents
    
    ' 取消复制状态
    Application.CutCopyMode = False
End Sub

关键说明： #

• lastRow和lastCol会自动识别你实际有数据的边界，不用手动写死范围
• 转置操作把多列数据变成单列，这样AdvancedFilter就能一次性提取所有唯一值
• 临时列用完可以删掉，保持工作表整洁

方法二：用数组+字典去重（高效首选，适合大数据） #

如果你的数据量比较大，用数组读取+字典去重的速度会快很多，而且不用临时列：

Sub ExtractUniqueWithArray()
    Dim sourceWS As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim dataArray As Variant, uniqueDict As Object
    Dim i As Long, j As Long
    Dim targetCell As Range
    
    ' 设置源工作表和唯一值的起始写入位置
    Set sourceWS = ThisWorkbook.Worksheets("Sheet1")
    Set targetCell = sourceWS.Range("B1")
    
    ' 动态获取数据范围
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, 1).End(xlUp).Row
    lastCol = sourceWS.Cells(1, sourceWS.Columns.Count).End(xlToLeft).Column
    dataArray = sourceWS.Range(sourceWS.Cells(1, 1), sourceWS.Cells(lastRow, lastCol)).Value
    
    ' 创建字典来自动存储唯一值（键不能重复）
    Set uniqueDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数组里的每一个单元格值
    For i = LBound(dataArray, 1) To UBound(dataArray, 1)
        For j = LBound(dataArray, 2) To UBound(dataArray, 2)
            ' 跳过空白单元格
            If Not IsEmpty(dataArray(i, j)) Then
                uniqueDict(dataArray(i, j)) = vbNullString
            End If
        Next j
    Next i
    
    ' 把字典里的唯一值写入目标列
    targetCell.Resize(uniqueDict.Count, 1).Value = Application.Transpose(uniqueDict.Keys)
End Sub

关键说明： #

• 数组读取数据比直接操作单元格快N倍，数据越多越明显
• 字典的特性就是键唯一，所以添加重复值会自动被忽略，完美实现去重
• 如果运行时报错，记得在VBA编辑器的「工具」→「引用」里勾选「Microsoft Scripting Runtime」

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