How to build a function to output a range of dynamic cells using VBA
I am creating a function that when you select a cell, it outputs the range of cells from the selection to the last filled row of a cell in the same column.
Here is some code that works great.
''Get the cell range from selection to last cell
Function CellRange(CellA As Range)
CellRange = CellA.Address + ":" + CellA.End(xlDown).Address
End Function
Question: I want to update this code so that when used for dates, the user can filter three options: from the beginning of the year (by date), ALL (all time - i.e. getting all data), year (i.e. 2015/2014 / 2013, etc.).)
My ultimate goal is for the user to be able to select a cell in a date range column and enter YTD or ALL or a given year (i.e. 2014) and get the range with its filter.
EXAMPLE: The user writes =cellrange(A2,2014)
who should give $A$2:$A$23
, and if the user changes to =cellrange(A2,2014)
, it should result in $A$24:$A$40
as shown in the image.
I've tried various loops or counting, but I feel completely lost as none of my attempts seemed to make any sense.
I am looking for some kind of help: a guide or a solution to the problem, preferably as I want to build it after I have dealt with it (hence why I am doing it in VBA).
source to share
Here is a much shorter solution that works for all three scenarios and does not require the data worksheet to be active:
Public Function cellrange(rDates As Range, vFilter As Variant) As String
Dim i As Long, ndx1 As Long, ndx2 As Long, r As Range, vA As Variant, bErr As Boolean, bAll As Boolean
bErr = True
If IsDate(rDates) Then
With rDates.EntireColumn
i = rDates.Parent.Evaluate("count(" & .Address & ")")
Set r = .Cells(1 - i + rDates.Parent.Evaluate("index(" & .Address & ",match(9.9E+307," & .Address & "))").Row).Resize(i, 1)
End With
vA = r.Value
Select Case LCase(vFilter)
Case "all": bErr = 0: bAll = 1
Case "ytd"
For i = 1 To UBound(vA)
If ndx1 = 0 And Year(vA(i, 1)) = Year(Date) Then ndx1 = i
If vA(i, 1) <= Date Then ndx2 = i
Next
Case Else 'year
vFilter = Val(vFilter)
If vFilter Then
For i = 1 To UBound(vA)
If ndx1 = 0 And Year(vA(i, 1)) = vFilter Then ndx1 = i
If ndx1 And Year(vA(i, 1)) = vFilter Then ndx2 = i
Next
End If
End Select
If Not bAll Then If ndx1 > 0 And ndx2 > 0 Then Set r = r.Range(r.Parent.Cells(ndx1, 1), r.Parent.Cells(ndx2, 1)): bErr = False
If Not bErr Then cellrange = r.Address Else cellrange = CVErr(xlErrValue)
End If
End Function
source to share
I wrote some code that {I think} captures what you are trying to do. I will give him a few points. (1) Code throws an error #Value
if CellA
not a value Date
(I think this is for obvious reasons). (2) If the Year element in the formula does not match the year in CellA
, it also throws away #Value
. I'm not sure if you want this type of treatment back, but I personally thought it would be rather confusing for the user if they point to CellA
, from 2014 and they are looking for 2013 dates. Let me know if you would like this to change.
Take a look at the code, give it some test cases and let me know if anything else needs to be changed.
INVENTED ON THE BASIS OF NEW INFORMATION: I haven't had the time to test this code as usual, but see if it works better for you.
Function cellrange(cellA As Range, vFilter As Variant) As String
Dim rStart As Range
Dim rEnd As Range
Dim bFinished As Boolean
Dim dToday As Date
Dim nOffset As Integer
'Throw an error if cell is not a date cell
If Not IsDate(cellA) Then
cellrange = CVErr(xlErrValue)
End If
If IsNumeric(vFilter) Then
If vFilter = Year(cellA) Then
'Below code if there is a year entered as vFilter
Set rStart = cellA
bFinished = False
'Loop to find start of year range
Do
If IsDate(rStart.Offset(-1)) Then
If Year(rStart.Offset(-1)) = vFilter Then
Set rStart = rStart.Offset(-1)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
'Loop to find end of year range
Set rEnd = cellA
bFinished = False
Do
If IsDate(rEnd.Offset(1)) Then
If Year(rEnd.Offset(1)) = vFilter Then
Set rEnd = rEnd.Offset(1)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
cellrange = rStart.Address & ":" & rEnd.Address
Else
If Year(cellA) > vFilter Then
nOffset = -1
Else
nOffset = 1
End If
Set rEnd = cellA
bFinished = False
Do
If IsDate(rEnd.Offset(nOffset)) Then
If Year(rEnd.Offset(nOffset)) <> vFilter Then
Set rEnd = rEnd.Offset(nOffset)
Else
Set rEnd = rEnd.Offset(nOffset)
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
Set rStart = rEnd
bFinished = False
Do
If IsDate(rStart.Offset(nOffset)) Then
If Year(rStart.Offset(nOffset)) = Year(rStart) Then
Set rStart = rStart.Offset(nOffset)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
If nOffset = -1 Then
cellrange = rStart.Address & ":" & rEnd.Address
Else
cellrange = rEnd.Address & ":" & rStart.Address
End If
End If
Else
If vFilter = "YTD" Then
'Below code if there is 'YTD' entered as vFilter
Set rStart = cellA
bFinished = False
dToday = Date
'Loop to find start of year range
Do
If IsDate(rStart.Offset(-1)) Then
If Year(rStart.Offset(-1)) = Year(rStart) Then
Set rStart = rStart.Offset(-1)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
'Loop to find end of year range
Set rEnd = cellA
bFinished = False
Do
If rEnd > dToday Then
nOffset = -1
If IsDate(rEnd.Offset(nOffset)) Then
If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) >= dToday Then
Set rEnd = rEnd.Offset(nOffset)
Else
bFinished = True
End If
Else
bFinished = True
End If
Else
nOffset = 1
If IsDate(rEnd.Offset(nOffset)) Then
If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) <= dToday Then
Set rEnd = rEnd.Offset(nOffset)
Else
bFinished = True
End If
Else
bFinished = True
End If
End If
Loop While bFinished = False
cellrange = rStart.Address & ":" & rEnd.Address
Else
'Below returns the 'ALL' case
Set rStart = cellA
bFinished = False
'Loop to find start of year range
Do
If IsDate(rStart.Offset(-1)) Then
Set rStart = rStart.Offset(-1)
Else
bFinished = True
End If
Loop While bFinished = False
'Loop to find end of year range
Set rEnd = cellA
bFinished = False
Do
If IsDate(rEnd.Offset(1)) Then
Set rEnd = rEnd.Offset(1)
Else
bFinished = True
End If
Loop While bFinished = False
cellrange = rStart.Address & ":" & rEnd.Address
End If
End If
End Function
Old, pre-edited code
Function cellrange(cellA As Range, vFilter As Variant) As String
Dim rStart As Range
Dim rEnd As Range
Dim bFinished As Boolean
Dim dToday As Date
Dim nOffset As Integer
'Throw an error if cell is not a date cell
If Not IsDate(cellA) Then
cellrange = CVErr(xlErrValue)
End If
'Throw an error if the cell year does not match the value being searched
If IsNumeric(vFilter) And vFilter <> Year(cellA) Then
cellrange = CVErr(xlErrValue)
End If
If IsNumeric(vFilter) Then
'Below code if there is a year entered as vFilter
Set rStart = cellA
bFinished = False
'Loop to find start of year range
Do
If IsDate(rStart.Offset(-1)) Then
If Year(rStart.Offset(-1)) = vFilter Then
Set rStart = rStart.Offset(-1)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
'Loop to find end of year range
Set rEnd = cellA
bFinished = False
Do
If IsDate(rEnd.Offset(1)) Then
If Year(rEnd.Offset(1)) = vFilter Then
Set rEnd = rEnd.Offset(1)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
cellrange = rStart.Address & ":" & rEnd.Address
Else
If vFilter = "YTD" Then
'Below code if there is 'YTD' entered as vFilter
Set rStart = cellA
bFinished = False
dToday = Date
'Loop to find start of year range
Do
If IsDate(rStart.Offset(-1)) Then
If Year(rStart.Offset(-1)) = Year(rStart) Then
Set rStart = rStart.Offset(-1)
Else
bFinished = True
End If
Else
bFinished = True
End If
Loop While bFinished = False
'Loop to find end of year range
Set rEnd = cellA
bFinished = False
Do
If rEnd > dToday Then
nOffset = -1
If IsDate(rEnd.Offset(nOffset)) Then
If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) >= dToday Then
Set rEnd = rEnd.Offset(nOffset)
Else
bFinished = True
End If
Else
bFinished = True
End If
Else
nOffset = 1
If IsDate(rEnd.Offset(nOffset)) Then
If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) <= dToday Then
Set rEnd = rEnd.Offset(nOffset)
Else
bFinished = True
End If
Else
bFinished = True
End If
End If
' If IsDate(rEnd.Offset(nOffset)) Then
' If Year(rEnd.Offset(nOffset)) = Year(rEnd) And rEnd.Offset(nOffset) < dToday Then
' Set rEnd = rEnd.Offset(nOffset)
' Else
' bFinished = True
' End If
' Else
' bFinished = True
' End If
Loop While bFinished = False
cellrange = rStart.Address & ":" & rEnd.Address
Else
'Below returns the 'ALL' case
Set rStart = cellA
bFinished = False
'Loop to find start of year range
Do
If IsDate(rStart.Offset(-1)) Then
Set rStart = rStart.Offset(-1)
Else
bFinished = True
End If
Loop While bFinished = False
'Loop to find end of year range
Set rEnd = cellA
bFinished = False
Do
If IsDate(rEnd.Offset(1)) Then
Set rEnd = rEnd.Offset(1)
Else
bFinished = True
End If
Loop While bFinished = False
cellrange = rStart.Address & ":" & rEnd.Address
End If
End If
End Function
source to share
A slightly more compact function ...
To use it in a spreadsheet, the listed values will not work; eg. use '= CellRange (C3, 1)'
Public Enum xlDateAction
xlYearToDate = 1
xlCurrentYear = 2
xlAll = 3
End Enum
Public Function CellRange(SrcCell As Range, DtRange As xlDateAction) As String
Application.ScreenUpdating = False
If Not IsDate(SrcCell.Value) Then Exit Function
Dim CellDate As Date: CellDate = SrcCell.Value
Dim EndCell As Range
Set EndCell = Columns(SrcCell.Column).Find(What:="", After:=[SrcCell]).Offset(-1, 0)
Dim StartCell As Range: Set StartCell = SrcCell
Do Until StartCell.Row = 1 Or Not IsDate(StartCell.Value)
Set StartCell = StartCell.Offset(-1, 0)
Loop
If Not IsDate(StartCell.Value) Then Set StartCell = StartCell.Offset(1, 0)
If DtRange <> xlAll Then
Dim SrcYear As Long: SrcYear = Year(CDate(SrcCell.Value))
Do Until StartCell.Address = SrcCell.Address Or Year(CDate(StartCell.Value)) = SrcYear
If Year(CDate(StartCell.Value)) < SrcYear Then Set StartCell = StartCell.Offset(1, 0)
Loop
If DtRange = xlCurrentYear Then
Do Until EndCell.Address = SrcCell.Address Or Year(CDate(EndCell.Value)) = SrcYear
If Year(CDate(EndCell.Value)) > SrcYear Then Set EndCell = EndCell.Offset(-1, 0)
Loop
Else
Set EndCell = SrcCell
End If
End If
CellRange = Range(StartCell, EndCell).Address
Application.ScreenUpdating = True
End Function
******* UPDATE *******
Added a function to override the year, which I think should now select the range you want ... (Also changed the enum as it now makes sense to me now)
Public Enum xlDateAction
xlCurrentYear = 1
xlYearToDate = 2
xlAll = 3
End Enum
Public Function CellRange(SrcCell As Range, DtRange As xlDateAction, _
Optional YearOverride As Long = 0) As String
Application.ScreenUpdating = False
If Not IsDate(SrcCell.Value) Then Exit Function
If YearOverride = Year(CDate(SrcCell.Value)) Then YearOverride = 0
Dim TargetYear As Long: TargetYear = YearOverride
Dim StartCell As Range: Set StartCell = SrcCell
Dim EndCell As Range
Set EndCell = Columns(SrcCell.Column).Find(What:="", After:=[SrcCell]).Offset(-1, 0)
Do Until StartCell.Row = 1 Or Not IsDate(StartCell.Value)
Set StartCell = StartCell.Offset(-1, 0)
Loop
If Not IsDate(StartCell.Value) Then Set StartCell = StartCell.Offset(1, 0)
If TargetYear = 0 Then TargetYear = Year(CDate(SrcCell.Value))
If DtRange <> xlAll Then
Do Until StartCell.Address = EndCell.Address Or Year(CDate(StartCell.Value)) >= TargetYear
If Year(CDate(StartCell.Value)) < TargetYear Then Set StartCell = StartCell.Offset(1, 0)
Loop
If DtRange = xlYearToDate And Year(CDate(StartCell.Value)) >= TargetYear And _
TargetYear > Year(CDate(SrcCell.Value)) Then Set StartCell = StartCell.Offset(-1, 0)
If DtRange = xlCurrentYear Then
Do Until EndCell.Address = StartCell.Address Or Year(CDate(EndCell.Value)) <= TargetYear
If Year(CDate(EndCell.Value)) > TargetYear Then Set EndCell = EndCell.Offset(-1, 0)
Loop
' If target year doesn't exist in dates
If Year(CDate(EndCell.Value)) <> TargetYear Then Exit Function
Else
Set EndCell = SrcCell
End If
End If
CellRange = Range(StartCell, EndCell).Address
Application.ScreenUpdating = True
End Function
source to share
Much of this can be easily accomplished using just an Excel formula. The same logic can be used to design a VBA function
I just noticed that your dates do not cover from the first to the last month. It shouldn't affect the original YTD / ALL, but if you want the first and last date specified, this will work
source to share