尝试使用函数获取范围内的行数-在VBA中有效，但在单元格中调用时无效

Question

我需要一个函数，该函数需要一个单元格，并提供该单元格当前区域中的行数。在屏幕截图中，它是B2：B5，所以是4行，因此该函数在应用于B2，B3，B4或B5时需要返回4。

我已在VBA中实现它（请参见屏幕快照中的VBA窗口）。另外，请参见下面的代码：

Function range_rows(sheet_name As String, range_address As String)
range_rows = Sheets(sheet_name).Range(range_address).CurrentRegion.Rows.Count
End Function

当我在VBA中调用它时有效（请参见屏幕快照中的即时窗口）。换句话说，调用

range_rows("Sheet1", "$B$3")

返回4。

但是，如果我在工作表的一个单元格中调用相同的函数，则会得到1（请参见屏幕快照中的单元格B11）。

任何人都知道如何解决此问题（或者，我如何编写一个可以完成相同功能的函数）？谢谢

Answer 1

[下面是赫伯特先生的代码，我修正了一个错字，并做了两个快速更改以使行数计数。 （看到：https://answers.microsoft.com/en-us/msoffice/forum/all/function-call-substitute-for-currentregion/bd0e7cc7-61cc-471c-b1e7-68ee0af03e67）

因为UDF的参数中未提及已更改的单元格，所以当当前区域更改时，不会重新计算UDF。因此，您需要输入：Application.volatile

在工作表中：= CustomCurrentRegion（Sheet1！G34）'根据需要更改工作表和单元格>

在模块中：

    Option Explicit


    Function CustomCurrentRegion(Rng As Range) 'deleted to 'quickfit' for your needs
    '---------------------------------------------------------------------
    'INFO:      06/15/2010, Matthew Herbert
    '---------------------------------------------------------------------
    'PURPOSE:   The CurrentRegion property of the Range Object will NOT
    '           work when called from a function.  As a result, this
    '           function mimics the CurrentRegion property (i.e. select
    '           a cell(s) within the worksheet and press Ctrl+Shift+* on
    '           the keyboard to see a visual selection of CurrentRegion,
    '           or access CurrentRegion from the "Go To" dialog box under
    '           the "Special" button).
    '
    '           The function is intended to be called from ONE cell, and
    '           the range used within the function is set to Rng(1) and
    '           NOT the ActiveCell within Rng.
    '
    'Rng        [in] A reference range from which the current region is
    '                built.
    '
    'RETURNS:   Nothing      - This result should NEVER occur, though it's
    '                          coded for a "just in case" scenario.
    '           Range Object - The Range of the current region
    '---------------------------------------------------------------------
    'UTILIZES:  GetOuterRange
    '---------------------------------------------------------------------
    'NOTES:     I have not exhaustively tested .CurrentRegion b/c I
    '           don't see a need for testing it such that CustomCurrentRegion
    '           behaves the same way.  In a normal scenario, I get the
    '           .CurrentRegion from a single cell Range.
    '
    '           One may want to change the Rng(1) to the ActiveCell within
    '           Rng.
    '
    'PATTERNS:  Diagonal directions are a combination of Up/Down and Left/Right.
    '           Up/Left and Down/Right have similar structures (in context
    '           of evaluating the code below).
    '
    '                       UP  DOWN  LEFT  RIGHT
    '           Exit Do     =0  >Max   =0    >Max
    '           Inc/Dec     -1   +1    -1    +1
    '           rngTemp     +1   -1    +1    -1
    '
    '           Regular directions (Top, Bottom, Left, Right) are also similar
    '           in structure (in context of evaluating the code below).
    '           You'll see a pattern with Top and Left and Bottom and Right.
    '
    '                       TOP                     LEFT                    BOTTOM                  RIGHT
    '           Need        Top - 1                 Top                                             Top
    '                       Lft                     Lft - 1                 Lft
    '                       Rgt                                             Rgt                     Rgt + 1
    '                                               Bot                     Bot + 1
    '
    '           Exit Do     Top=0                   Lft=0                   Bot>Max                 Rgt>Max
    '
    '           rngEval     [Need]                  [Need]                  [Need]                  [Need]
    '
    '           lOffset     .Cells(1).Row           .Cells(1).Column        (Bot - 1) - .Cells(     (Rgt - 1) - .Cells(
    '                       - (Top + 1)             - (Lft + 1)             .Cells.Count).Row       .Cells.Count).Column
    '
    '           Resize      .Offset(-lOffset)       .Offset(,-lOffset)      .Resize(.Rows           .Resize(,.Columns
    '                       .Resize(.Rows           .Resize(,.Columns       .Count + lOffset)       .Count + lOffset)
    '                       .Count + lOffset)       .Count + lOffset)
    '---------------------------------------------------------------------

    Dim lngRowMax As Long
    Dim intColMax As Integer
    Dim lngRowTop As Long
    Dim lngRowBot As Long
    Dim lngOffset As Long
    Dim intOffset As Integer
    Dim intColLft As Integer
    Dim intColRgt As Integer
    Dim Wks As Worksheet
    Dim rngTemp As Range
    Dim rngResize As Range
    Dim rngEval As Range
    Dim rngOuter As Range
    Dim blnAdd As Boolean

Application.volatile 'see above

    'get a worksheet object reference to Rng (for use in With blocks)
    Set Wks = Rng.Parent

    'set the range to be "resized" as part of the CurrentRegion process
    '   NOTE:  this is the first cell in Rng and not something else (such as the
    '          ActiveCell within Rng)
    Set rngResize = Rng(1)

    'get the max rows and columns of the worksheet, i.e. get the worksheet bounds
    '   (which creates an interesting dynamic due to the fact that there is no
    '   Cells(0,0) in the worksheet)
    With Wks
        lngRowMax = .Rows.Count
        intColMax = .Columns.Count
    End With

    'get the row and column numbers for the cell
    With rngResize
        With .Cells(1)
            lngRowTop = .Row
            intColLft = .Column
        End With

        With .Cells(.Cells.Count)
            lngRowBot = .Row
            intColRgt = .Column
        End With
    End With

    'get the "outer region," i.e. one row above, one row below,
    '   one column left, and one column right
    If lngRowTop <> 1 Then lngRowTop = lngRowTop - 1
    If intColLft <> 1 Then intColLft = intColLft - 1
    If lngRowBot <> lngRowMax Then lngRowBot = lngRowBot + 1
    If intColRgt <> intColMax Then intColRgt = intColRgt + 1

    'return a Range Object that corresponds to the "outer region"
    Set rngOuter = GetOuterRange(rngResize)
        'Debug.Print "OuterRange:"; rngOuter.Address

    'loop until you can't find anything in the outer region's cells
    Do Until Application.WorksheetFunction.CountA(rngOuter) = 0

    '--------------------------------------------------------------------
    'GENERAL COMMENTS:
    '   The code below will "move" in the stated direction, looking
    '   for additional data contained in that direction.  If data is
    '   found, then the range is expanded and the process "restarts"
    '   its loop.  The diagonal directions are structured slightly
    '   different (meaning a range object--rngTemp--is being used)
    '   than the non-diagonal directions.
    '
    '   Though the code below is not explicitly commented, note the
    '   +1 or -1 to .Row and/or .Column.  Also, blnAdd is used as a flag
    '   to determine whether the range needs to be resized to include
    '   new data found in the specified search direction.
    '--------------------------------------------------------------------

    '------------------------------------------------------
    'upper left direction
        Set rngTemp = rngResize
        blnAdd = False
        With rngResize
            With .Cells(1)
                lngRowTop = .Row - 1
                intColLft = .Column - 1
            End With
        End With

        'continue to search in the specified direction for data to
        '   be added.  If data needs to be added, then blnAdd will
        '   be set to True and the range will be resized later.
        Do
            If lngRowTop = 0 Or intColLft = 0 Then Exit Do
            If IsEmpty(Wks.Cells(lngRowTop, intColLft)) Then Exit Do

            blnAdd = True
            lngRowTop = lngRowTop - 1
            intColLft = intColLft - 1
        Loop

        If blnAdd Then
            With Wks
                Set rngTemp = .Cells(lngRowTop + 1, intColLft + 1)
            End With
            Set rngResize = Range(rngResize, rngTemp)
                'Debug.Print "UpLft:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'upper right direction
        Set rngTemp = rngResize
        blnAdd = False
        With rngResize
            lngRowTop = .Cells(1).Row - 1
            With .Cells(.Cells.Count)
                intColRgt = .Column + 1
            End With
        End With

        Do
            If lngRowTop = 0 Or intColRgt > intColMax Then Exit Do
            If IsEmpty(Wks.Cells(lngRowTop, intColRgt)) Then Exit Do

            blnAdd = True
            lngRowTop = lngRowTop - 1
            intColRgt = intColRgt + 1
        Loop

        If blnAdd Then
            With Wks
                Set rngTemp = .Cells(lngRowTop + 1, intColRgt - 1)
                    'Debug.Print "  Tmp:"; rngTemp.Address
            End With
            Set rngResize = Range(rngResize, rngTemp)
                'Debug.Print "UpRgt:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'bottom right direction
        Set rngTemp = rngResize
        blnAdd = False
        With rngResize
            With .Cells(.Cells.Count)
                lngRowBot = .Row + 1
                intColRgt = .Column + 1
            End With
        End With

        Do
            If lngRowBot > lngRowMax Or intColRgt > intColMax Then Exit Do
            If IsEmpty(Wks.Cells(lngRowBot, intColRgt)) Then Exit Do

            blnAdd = True
            lngRowBot = lngRowBot + 1
            intColRgt = intColRgt + 1
        Loop

        If blnAdd Then
            With Wks
                Set rngTemp = .Cells(lngRowBot - 1, intColRgt - 1)
                    'Debug.Print "  Tmp:"; rngTemp.Address
            End With
            Set rngResize = Range(rngResize, rngTemp)
                'Debug.Print "DwRgt:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'bottom left direction
        Set rngTemp = rngResize
        blnAdd = False
        With rngResize
            With .Cells(.Cells.Count)
                lngRowBot = .Row + 1
            End With
            intColLft = .Cells(1).Column - 1
        End With

        Do
            If lngRowBot > lngRowMax Or intColLft = 0 Then Exit Do
            If IsEmpty(Wks.Cells(lngRowBot, intColLft)) Then Exit Do

            blnAdd = True
            lngRowBot = lngRowBot + 1
            intColLft = intColLft - 1
        Loop

        If blnAdd Then
            With Wks
                Set rngTemp = .Cells(lngRowBot - 1, intColLft + 1)
                    'Debug.Print "  Tmp:"; rngTemp.Address
            End With
            Set rngResize = Range(rngResize, rngTemp)
                'Debug.Print "DwLft:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'top direction
        blnAdd = False
        With rngResize
            With .Cells(1)
                lngRowTop = .Row - 1
                intColLft = .Column
            End With

            With .Cells(.Cells.Count)
                lngRowBot = .Row
                intColRgt = .Column
            End With
        End With

        Do
            If lngRowTop = 0 Then Exit Do

            With Wks
                Set rngEval = .Range(.Cells(lngRowTop, intColLft), _
                                     .Cells(lngRowTop, intColRgt))
            End With

            If Application.WorksheetFunction.CountA(rngEval) = 0 Then Exit Do

            blnAdd = True
            lngRowTop = lngRowTop - 1
        Loop

        If blnAdd Then
            With rngResize
                lngOffset = .Cells(1).Row - (lngRowTop + 1)
                Set rngResize = .Offset(-lngOffset).Resize(.Rows.Count + lngOffset)
            End With
            'Debug.Print "  Top:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'right direction
        blnAdd = False
        With rngResize
            With .Cells(1)
                lngRowTop = .Row
                intColLft = .Column
            End With

            With .Cells(.Cells.Count)
                lngRowBot = .Row
                intColRgt = .Column + 1
            End With
        End With

        Do
            If intColRgt > intColMax Then Exit Do
            'If lngRowTop = 0 Then lngRowTop = 1

            With Wks
                Set rngEval = .Range(.Cells(lngRowTop, intColRgt), _
                                     .Cells(lngRowBot, intColRgt))
            End With

            If Application.WorksheetFunction.CountA(rngEval) = 0 Then Exit Do

            blnAdd = True
            intColRgt = intColRgt + 1
        Loop

        If blnAdd Then
            With rngResize
                intOffset = (intColRgt - 1) - .Cells(.Cells.Count).Column
                Set rngResize = .Resize(, .Columns.Count + intOffset)
            End With
            'Debug.Print "  Rgt:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'bottom direction
        blnAdd = False
        With rngResize
            With .Cells(1)
                lngRowTop = .Row
                intColLft = .Column
            End With

            With .Cells(.Cells.Count)
                lngRowBot = .Row + 1
                intColRgt = .Column
            End With
        End With

        Do
            If lngRowBot > lngRowMax Then Exit Do

            With Wks
                Set rngEval = .Range(.Cells(lngRowBot, intColLft), _
                                     .Cells(lngRowBot, intColRgt))
            End With

            If Application.WorksheetFunction.CountA(rngEval) = 0 Then Exit Do

            blnAdd = True
            lngRowBot = lngRowBot + 1
        Loop

        If blnAdd Then
            With rngResize
                lngOffset = (lngRowBot - 1) - .Cells(.Cells.Count).Row
                Set rngResize = .Resize(.Rows.Count + lngOffset)
            End With
            'Debug.Print "  Bot:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
    'left direction
        blnAdd = False
        With rngResize
            With .Cells(1)
                lngRowTop = .Row
                intColLft = .Column - 1
            End With

            With .Cells(.Cells.Count)
                lngRowBot = .Row
                intColRgt = .Column
            End With
        End With

        Do
            If intColLft = 0 Then Exit Do

            With Wks
                Set rngEval = .Range(.Cells(lngRowTop, intColLft), _
                                     .Cells(lngRowBot, intColLft))
            End With

            If Application.WorksheetFunction.CountA(rngEval) = 0 Then Exit Do

            blnAdd = True
            intColLft = intColLft - 1
        Loop

        If blnAdd Then
            With rngResize
                intOffset = .Cells(1).Column - (intColLft + 1)
                Set rngResize = .Offset(, -intOffset).Resize(, .Columns.Count + intOffset)
            End With
            'Debug.Print "  Lft:"; rngResize.Address
        End If
    '------------------------------------------------------

    '------------------------------------------------------
        'create outer range for the test in the Do Loop

        Set rngOuter = GetOuterRange(rngResize)
            'Debug.Print "OuterRange:"; rngOuter.Address
    '------------------------------------------------------
    Loop '--> Do Until Application.WorksheetFunction.CountA(rngOuter) = 0

    If Application.WorksheetFunction.CountA(rngOuter) = 0 Then
        Set CustomCurrentRegion = rngResize
    Else
        Set CustomCurrentRegion = Nothing
    End If

    'added for your needs
    CustomCurrentRegion = CustomCurrentRegion.Rows.Count

    'explicitly clear the memory
    Set Wks = Nothing
    Set rngTemp = Nothing
    Set rngResize = Nothing
    Set rngEval = Nothing
    Set rngOuter = Nothing

    End Function

    Private Function GetOuterRange(Rng As Range) As Range
    '---------------------------------------------------------------------
    'INFO:      06/15/2010, Matthew Herbert
    '---------------------------------------------------------------------
    'PURPOSE:   Return the outer range of Rng.  If Rng is C3:D4 then the
    '           outer range is B2:E2 (Top), E2:E5 (Right), B5:E5 (Bottom),
    '           and B2:B5 (Left).
    '
    'Rng        [in] A reference range from which the outer region's range
    '                will be built.
    '
    'RETURNS:   Nothing      - This result should NEVER occur, though it's
    '                          coded for a "just in case" scenario.
    '           Range Object - The Range of the outer region
    '---------------------------------------------------------------------
    'UTILIZES:  N/A
    '---------------------------------------------------------------------
    'NOTES:     None
    '---------------------------------------------------------------------
    Dim lngRowMax As Long
    Dim intColMax As Integer
    Dim lngRowTop As Long
    Dim lngRowBot As Long
    Dim intColLft As Integer
    Dim intColRgt As Integer
    Dim lngRowT As Long
    Dim lngRowB As Long
    Dim intColL As Integer
    Dim intColR As Integer
    Dim lngCnt As Long
    Dim rngTop As Range
    Dim rngBot As Range
    Dim rngLft As Range
    Dim rngRgt As Range
    Dim rngRes As Range
    Dim rngArr(3) As Range
    Dim Wks As Worksheet

    'get a worksheet object reference to Rng (for use in With blocks)
    Set Wks = Rng.Parent

    'get the max rows and columns of the worksheet, i.e. get the worksheet bounds
    With Wks
        lngRowMax = .Rows.Count
        intColMax = .Columns.Count
    End With

    'get the row and column numbers for Rng
    With Rng
        With .Cells(1)
            lngRowTop = .Row - 1
            intColLft = .Column - 1
        End With

        With .Cells(.Cells.Count)
            lngRowBot = .Row + 1
            intColRgt = .Column + 1
        End With
    End With

    'check if the values are "out of bounds" and reset the variable appropriately
    If lngRowTop = 0 Then
        lngRowT = 1
    Else
        lngRowT = lngRowTop
    End If

    If lngRowBot > lngRowMax Then
        lngRowB = lngRowMax
    Else
        lngRowB = lngRowBot
    End If

    If intColLft = 0 Then
        intColL = 1
    Else
        intColL = intColLft
    End If

    If intColRgt > intColMax Then
        intColR = intColMax
    Else
        intColR = intColRgt
    End If

    'set up the Top, Bottom, Left, and Right ranges based on whether the bounds
    '   are in or out of the worksheet.  Store the ranges in an array, which
    '   will be combined via Union later.  If a range is Nothing, then we'll ignore
    '   it when we loop through the array.
    'don't look too lightly at the .Range(.Cells(),.Cells()) portion below b/c
    '   you have to "keep your ducks in a row"
    With Wks
        If lngRowTop > 0 Then
            Set rngTop = .Range(.Cells(lngRowT, intColL), .Cells(lngRowT, intColR))
            Set rngArr(0) = rngTop
        End If

        If lngRowBot <= lngRowMax Then
            Set rngBot = .Range(.Cells(lngRowB, intColL), .Cells(lngRowB, intColR))
            Set rngArr(1) = rngBot
        End If

        If intColLft > 0 Then
            Set rngLft = .Range(.Cells(lngRowT, intColL), .Cells(lngRowB, intColL))
            Set rngArr(2) = rngLft
        End If

        If intColRgt <= intColMax Then
            Set rngRgt = .Range(.Cells(lngRowT, intColR), .Cells(lngRowB, intColR))
            Set rngArr(3) = rngRgt
        End If
    End With

    'loop through the array of ranges and add up the non-Nothing ranges
    For lngCnt = LBound(rngArr) To UBound(rngArr)
        If Not rngArr(lngCnt) Is Nothing Then
            If rngRes Is Nothing Then
                Set rngRes = rngArr(lngCnt)
            Else
                Set rngRes = Union(rngRes, rngArr(lngCnt))
            End If
        End If
    Next lngCnt

    'return the result
    If rngRes Is Nothing Then
        Set GetOuterRange = Nothing
    Else
        Set GetOuterRange = rngRes
    End If

    'explicitly clear the memory
    Set rngTop = Nothing
    Set rngBot = Nothing
    Set rngLft = Nothing
    Set rngRgt = Nothing
    Set rngRes = Nothing
    Set rngArr(0) = Nothing
    Set rngArr(1) = Nothing
    Set rngArr(2) = Nothing
    Set rngArr(3) = Nothing
    Set Wks = Nothing
    End Function