Ниже приведен код от М. Герберта, я исправил опечатку и сделал два быстрых изменения, чтобы получить количество строк. (см .: 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