vba - Excel UDF 过滤器范围

Question

我有一个函数，它将一系列值作为输入（只是一列）以及一些阈值。我想返回一个经过过滤的范围，以包含原始范围中大于阈值的所有值。我有以下代码：

Public Function FilterGreaterThan(Rng As Range, Limit As Double) As Range

Dim Cell As Range
Dim ResultRange As Range

For Each Cell In Rng
    If Abs(Cell.Value) >= Limit Then
        If ResultRange Is Nothing Then
            Set ResultRange = Cell
        Else
            Set ResultRange = Union(ResultRange, Cell)
        End If
    End If    
Next
Set FilterGreaterThan = ResultRange
End Function

问题在于，一旦某个数字低于阈值，则该数字之后高于阈值的其他数字不会添加到该范围中。

例如：

Threshold - 2

Numbers -

3
4
1
5

它将循环添加 3 和 4，但不会添加 5。我最终得到一个#value 错误。但是我没有收到任何错误，如果我只输入范围 - 3、4 或范围 - 3、4、1，它就可以正常工作。

Answer 1

看起来 UDF 不喜欢将非连续范围写回数组。

一种解决方法是重写 UDF，如下所示。它假定输出数组仅在列中，但确实允许多列输入。

Option Explicit

Public Function FilterGreaterThan(Rng As Range, Limit As Double) As Variant

Dim Cell As Range
Dim WriteArray() As Variant
Dim i As Long
Dim cellVal As Variant
Dim CountLimit As Long

CountLimit = WorksheetFunction.CountIf(Rng, ">=" & Limit)
ReDim WriteArray(1 To CountLimit, 1 To 1) 'change if more than 1 column
For Each Cell In Rng

    cellVal = Cell.Value
    If Abs(cellVal) >= Limit Then
            i = i + 1 'change if more than 1 column
            WriteArray(i, 1) = cellVal 'change if more than 1 column
    End If
Next
FilterGreaterThan = WriteArray
End Function

Answer 2

哦，我先到了那里，但我现在已经把它打出来了，所以我不妨把它贴出来。此版本将作为正确大小的列向量返回。

如果没有匹配项，则在 1 x 1 数组中返回 #N/A（这与数组函数在没有足够值填充数组时的正常行为一致）

edit2：由于 ooo 的评论更新了功能

Public Function FilterGreaterThan(Rng As Range, Limit As Double) As Variant()

Dim inputCell As Range ' each cell we read from
Dim resultCount As Integer ' number of matching cells found
Dim resultValue() As Variant ' array of cell values

resultCount = 0
ReDim resultValue(1 To 1, 1 To Rng.Cells.Count)

For Each inputCell In Rng
    If Abs(inputCell.Value) >= Limit Then
        resultCount = resultCount + 1
        resultValue(1, resultCount) = inputCell.Value
    End If
Next inputCell

' Output array must be two-dimensional and we can only
' ReDim Preserve the last dimension
If (resultCount > 0) Then
    ReDim Preserve resultValue(1 To 1, 1 To resultCount)
Else
    resultValue(1, 1) = CVErr(xlErrNA)
    ReDim Preserve resultValue(1 To 1, 1 To 1)
End If

' Transpose the results to produce a column rather than a row
resultValue = Application.WorksheetFunction.Transpose(resultValue)

FilterGreaterThan = resultValue

End Function

---

编辑：对我来说可以使用下面评论中的测试值：

我确定您知道这一点，但在输入数组公式时不要包含{or}字符 - Excel 在您按下 Ctrl-Shift-Enter 后将它们添加