如何用VBA宏实现Excel按条件筛选并粘贴唯一值到指定列

方法1：直接通过VBA写入原公式 #

这种方式和你手动输入公式的效果完全一致，适合支持UNIQUE和FILTER函数的Excel版本（365/2021及以上）：

Sub ExtractUniqueValuesWithFormula()
    ' 清除M列从M2开始的现有数据
    Range("M2:M" & Cells(Rows.Count, "M").End(xlUp).Row).ClearContents
    
    ' 在M2单元格写入动态数组公式
    Range("M2").Formula2 = "=UNIQUE(FILTER(A:A, D:D<(MIN(D:D)+20), ""No results""))"
End Sub

说明：使用Formula2是因为动态数组函数需要该属性来确保正确解析，部分场景下Formula也能生效，但Formula2兼容性更稳妥。

方法2：纯VBA逻辑实现（兼容旧版Excel） #

如果你的Excel版本不支持动态数组函数，可以用VBA手动完成计算、筛选和去重：

Sub ExtractUniqueValuesVBA()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim minD As Double
    Dim cell As Range
    Dim uniqueValues As Collection
    Dim outputArr() As Variant
    Dim i As Integer
    
    ' 指定目标工作表，可改为具体表名如Sheets("Sheet1")
    Set ws = ActiveSheet
    ' 获取A列最后一行数据行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' 计算D列（从D2开始）的最小值
    minD = Application.WorksheetFunction.Min(ws.Range("D2:D" & lastRow))
    
    ' 初始化集合用于存储唯一值
    Set uniqueValues = New Collection
    
    On Error Resume Next ' 忽略重复值添加时的错误
    ' 遍历D列数据，筛选符合条件的A列值
    For Each cell In ws.Range("D2:D" & lastRow)
        If cell.Value < (minD + 20) Then
            ' 利用集合Key属性自动去重，重复值会触发错误并跳过
            uniqueValues.Add ws.Cells(cell.Row, "A").Value, Key:=CStr(ws.Cells(cell.Row, "A").Value)
        End If
    Next cell
    On Error GoTo 0 ' 恢复默认错误处理
    
    ' 清除M列所有数据
    ws.Range("M2:M" & ws.Rows.Count).ClearContents
    
    ' 将筛选后的唯一值写入M列
    If uniqueValues.Count > 0 Then
        ReDim outputArr(1 To uniqueValues.Count, 1 To 1)
        For i = 1 To uniqueValues.Count
            outputArr(i, 1) = uniqueValues(i)
        Next i
        ws.Range("M2").Resize(uniqueValues.Count, 1).Value = outputArr
    Else
        ' 无符合条件的数据时显示提示
        ws.Range("M2").Value = "No results"
    End If
    
    ' 释放对象
    Set uniqueValues = Nothing
    Set ws = Nothing
End Sub

代码说明： #

• 先计算D列最小值，再遍历D列每一行判断是否满足条件
• 借助Collection的Key属性自动实现去重，无需额外判断
• 最后将集合中的值转为数组批量写入M列，比逐个写入单元格效率更高

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