How to build a dynamic cell range output function using VBA

Question

I am building a function, that when you select a cell, the output is the cell range from the selection to the last filled cell row on the same column.

Here is the code, that works perfectly.

''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 with three options: YTD (year to date), ALL (all time - i.e. getting all data), a year (i.e. 2015 / 2014 / 2013 etc.)

My end goal is for the user to select a cell in a range column of dates and input YTD or ALL or a given year (i.e. 2014) and get the range with his filter.

EXAMPLE: The user writes =cellrange(A2,2014), which should yield $A$2:$A$23 and if the user changes to =cellrange(A2,2014) this should yield $A$24:$A$40 as seen on the image.

I tried various loops or counts but I feel quite lost as none of my tries apparently made any sense.

I am looking for some help: guidance or a solution to the problem preferably, as I want to build up on it after I tackle this one (hence why I am doing it on VBA).

Answer 1

I've written some code that {I think} captures what it is that you're trying to do. I'll preface it with a few points. (1) The code throws the #Value error if CellA is not a Date value (I think this is for self-explanatory reasons). (2) If the Year entry in the formula doesn't match the year in CellA, it also throws #Value. I'm not sure if you wanted to return this type of treatment, but I personally thought it would be pretty confusing for a user if they point to CellA, with a year of 2014, and they're looking for 2013 dates. Let me know if you want this changed.

Take a look at the code, give it some test cases, and let me know if anything else needs to be modified.

EDITED BASED ON NEW INFORMATION: I didn't get as much time to test this code as I normally would, 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

---

Older, pre-edit 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

Answer 2

A slightly more compact function...

To use it in the spreadsheet, the enumerated values won't 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 year override function which I think should therefore now do the range selections you want... (Also tweaked the enum as it makes more sense to me now this way around)

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

Answer 3

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

Answer 4

Most of this can be done easily using just Excel formula. The same logic can be used to develop a VBA function

I just noticed that your dates do not cover the first to last of the month. It shouldn't affect the original YTD/ALL but if you need the first and last date specified then this will work