Excel UDF查找具有给定值的范围内的第一个和最后一个单元格-运行缓慢

Question

我正在编写一个函数，该函数采用列范围，并查找该列中具有特定值的第一个和最后一个单元格。 这给出了第一个行号和最后一个行号，然后将它们用于返回另一列中的相应子范围。
我的想法是，通过此函数，我可以将Excel函数应用于范围的（连续）子部分。 例如，假设我有一张桌子，上面列出了各种价格的苹果和香蕉，将它们分组，以便首先列出所有苹果价格，然后是香蕉。 我想找到苹果的最低价格和香蕉的最低价格，但要选择整个范围，而又不改变最小范围。 我将使用所需的函数将范围提供给Excel的MIN函数，该范围仅包括Apple或Bananas，而无需手动选择这些子范围。 一个MINIF（如果需要的话），就像SUMIF的一个弱版本，但用于MIN（可能还有许多其他功能）。
我已经找到了一种方法，但是它的运行速度非常慢。 我认为这可能与for循环有关，但是我对Excel / VBA的效率了解得不够，无法知道如何进行改进。 我在Excel表上使用此代码，因此我传递的列称为表对象的列。 我正在Windows 7 Enterprise上使用Excel 2010。

感谢您的帮助。 甚至关于如何有条件地将函数应用于与之完全偏离的范围的解决方案也广为接受。

码：

' ParentRange and CriterionRange are columns of the same table. 
'I want to extract a reference to the part of ParentRange which corresponds
'by rows to the part of CriterionRange that contains cells with a certain value.
Function CorrespondingSubrange(CriterionRange As Range, Criterion As _
String, ParentRange As Range) As Range

Application.ScreenUpdating = False

Dim RowCounter As Integer
Dim SubRangeFirstRow As Integer
Dim SubRangeFirstCell As Range
Dim SubRangeLastRow As Integer
Dim SubRangeLastCell As Range
Dim RangeCountStarted As Boolean

RangeCountStarted = False

Set SubRangeFirstCell = CriterionRange.Find(What:=Criterion, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

If Not (SubRangeFirstCell Is Nothing) Then
    RangeCountStarted = True
    SubRangeFirstRow = SubRangeFirstCell.Row - CriterionRange.Range("A1").Row + 1

    For RowCounter = SubRangeFirstRow To CriterionRange.Cells.Count

        If Not (CriterionRange.Cells(RowCounter, 1).Value = Criterion) Then
            SubRangeLastRow = RowCounter - 1
            Exit For
        End If

    Next

End If

If RangeCountStarted = True And SubRangeLastRow = 0 Then SubRangeLastRow = RowCounter

Set CorrespondingSubrange = ParentRange.Range("A" & SubRangeFirstRow & ":A" & SubRangeLastRow)

Application.ScreenUpdating = True
End Function

Answer 1

当Excel公式可以有效使用时，我不喜欢使用VBA。

首先，可以在数组公式中使用简单的IF根据条件获得最小值或最大值（使用Ctrl + Shift + Enter输入该公式。这将添加表示数组公式的周围的{} ）：

=MIN(IF($A$1:$A$10=D1,$B$1:$B$10))

该公式在A中检查D1中的条件，并从B中返回相应的值。请注意，您甚至不需要为该公式工作就可以对数据进行排序：

其次，如果要保持获取第一行和最后一行的行号，可以使用此公式加上少量的加法。 但是 ，我怀疑有人会将INDIRECT或OFFSET函数与这些值一起使用，这是不必要且效率低下的，因为此函数易变。 无论如何，公式的添加项是ROW函数。 （当然，此公式将需要对数据进行排序）。 行号的数组公式 ：

=MAX(IF($A$1:$A$10=D1,ROW($A$1:$A$10)))

这将返回Bananas的最后一行。

Answer 2

通过将“查找搜索方向”设置为xlPrevious，您可以轻松地查找范围中的最后一个匹配项。
当您仅读取值时，切换Application.ScreenUpdating效果不大。 我更喜欢较短的变量名。 较长的名称容易使屏幕混乱，并使得很难看清正在发生的事情。 但这只是我的意见。

Function CorrespondingSubrange(rCriterion As Range, Criterion As _
                                                        String, rParent As Range) As Range
    Dim FirstCell As Range
    Dim LastCell As Range

    Set FirstCell = rCriterion.Find(What:=Criterion, LookIn:=xlValues, _
                                                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
                                                MatchCase:=False, SearchFormat:=False)
    Set LastCell = rCriterion.Find(What:=Criterion, LookIn:=xlValues, _
                                                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
                                                MatchCase:=False, SearchFormat:=False)


    If Not (FirstCell Is Nothing) Then
        Set CorrespondingSubrange = rParent.Range("A" & FirstCell.Row & ":A" & LastCell.Row)
    End If
End Function

Answer 3

我的答案与Thomas Inzina先前发布的VBA UDF解决方案相似，但有一些区别。

After:=参数用于确保找到的第一个匹配项是该范围内的第一个匹配项。 Range.Find方法使用“锡罐”方法，在其中循环遍历hte range的单元格，并在到达末尾时从头开始重新启动。 通过启动After:=.Cells(.Cells.Count)并向前移动，您将找到匹配范围内的第一个单元格。 同样，通过从After:=.Cells(1)并移动SearchDirection:=xlPrevious您将快速找到最后一个而不循环。

我还使用了Intersect方法来a）减少对Worksheet.UsedRange属性的完整列引用，并b）快速从确定的标准范围返回工作范围。

Function CorrespondingSubrange(rngCriterion As Range, Criterion As String, _
                               rngWorking As Range) As Variant

    Dim SubRangeFirstCell As Range
    Dim SubRangeLastCell As Range

    'set the return value to an #N/A error (success will overwrite this)
    CorrespondingSubrange = CVErr(xlErrNA)

    'chop any full column references down to manageable ranges
    Set rngCriterion = Intersect(rngCriterion, rngCriterion.Parent.UsedRange)

    With rngCriterion

        'look forwards for the first occurance
        Set SubRangeFirstCell = .Find(What:=Criterion, After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

        If Not SubRangeFirstCell Is Nothing Then

            'there is at least one of the criteria - now look backwards
            Set SubRangeLastCell = .Find(What:=Criterion, After:=.Cells(1), _
                    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)

            Set CorrespondingSubrange = Intersect(rngWorking, Range(SubRangeFirstCell, SubRangeLastCell).EntireRow)

            Debug.Print CorrespondingSubrange.Address(0, 0, external:=True)

        End If
    End With

End Function