Search code examples
arraysfunctionvba7excel-2019

VBA Function that Returns Array on Worksheet will not Return Array with 1 Element


I'm trying to modify NHarker's Easter VBA to handle an array of dates. In my workbook, the user enters a start year and end year and a formula returns an array of the date of Easter for every year within the years the user entered. The formula spills into x number of rows where x is the number of years the user selected. NHarker's original VBA works when you feed it a single year, but I need it to handle an array of years. So, I modified the VBA, and it works when the number of years is 2 or more. However, the worksheet function returns the VALUE error when the start and end years are the same.

'=========================================
Function EASTER_by_NHarker(year As Variant) As Variant
'Based on Claus Tondering algorithm interpretation.
'See https://www.tondering.dk/claus/cal/calendar29.html
'Norman Harker 10-Jul-2004
'
' Modified by Clint E to handle arrays 2023-09-25

  Dim G As Integer: Dim C As Integer: Dim H As Integer
  Dim i As Integer: Dim J As Integer: Dim L As Integer
  Dim EM As Integer: Dim ED As Integer
  Dim Adj1904 As Integer

  Dim YearsArray As Variant
  Dim DatesArray() As Variant
  Dim OutputArray() As Variant
  Dim x As Long, y As Long

  ' Fill the array
  Select Case Application.WorksheetFunction.Count(year)
    Case 0
        Exit Function
    Case 1
        ReDim YearsArray(2, 1)
        YearsArray(1, 1) = year
        YearsArray(2, 1) = 0
    Case Else
        YearsArray = year
  End Select

  ReDim DatesArray(1 To UBound(YearsArray, 1))
  For x = 1 To UBound(YearsArray, 1)

    If Not IsDate("1/1/" & YearsArray(x, 1)) Then
        EASTER_by_NHarker = "Excel Year Limit Error"
        Exit Function
    End If

    G = YearsArray(x, 1) Mod 19
    C = YearsArray(x, 1) \ 100
    H = (C - C \ 4 - (8 * C + 13) \ 25 + 19 * G + 15) Mod 30
    i = H - (H \ 28) * (1 - (29 \ (H + 1)) * ((21 - G) \ 11))
    J = (YearsArray(x, 1) + YearsArray(x, 1) \ 4 + i + 2 - C + C \ 4) Mod 7
    L = i - J
    EM = 3 + (L + 40) \ 44
    ED = L + 28 - (31 * (EM \ 4))
    If ActiveWorkbook.Date1904 = True Then
      Adj1904 = 365 * 4 + 2
    End If
    DatesArray(x) = CDate(Trim((DateSerial(YearsArray(x, 1), EM, ED) - Adj1904)))
  Next

  Select Case Application.WorksheetFunction.Count(year)
    Case 1
        EASTER_by_NHarker = Application.Transpose(Array(DatesArray(1), ""))
    Case Else
        EASTER_by_NHarker = Application.Transpose(DatesArray)
  End Select

End Function
'=========================================

I would like the function to return the date of Easter for that 1 year in this scenario. I've tried various things like hardcoding a 0 for the second element and then dropping it later in the VBA and overriding with an empty item ("") as the second element, but the worksheet function will not return the single element. I've been tinkering with it for days now. Can someone please assist?


Solution

  • I was finally able to get this to work. In case it helps someone out there, here's what I did.

    On the worksheet, I was using a SEQUENCE function inside the EASTER_by_NHarker function. So, something like this:

    =EASTER_by_NHarker(SEQUENCE(END_YEAR-START_YEAR+1,1,START_YEAR,1))
    

    This worked when the END_YEAR was any year after the START_YEAR, but it didn't work if the END_YEAR and START_YEAR were the same. So, I used an IF formula to handle the scenario where the start and end years are the same. This is the final formula:

    =EASTER_by_NHarker(IF(END_YEAR = START_YEAR,START_YEAR,SEQUENCE(END_YEAR-START_YEAR+1,1,START_YEAR,1)))
    

    And, here's the final VBA script I used to make the Easter function work with an array of years.

    Function EASTER_by_NHarker(year As Variant) As Variant
    'Based on Claus Tondering algorithm interpretation.
    'See https://www.tondering.dk/claus/cal/calendar29.html
    'Norman Harker 10-Jul-2004
    '
    ' Modified by Clint E to handle arrays 2023-09-25
    
      Dim G As Integer: Dim C As Integer: Dim H As Integer
      Dim i As Integer: Dim J As Integer: Dim L As Integer
      Dim EM As Integer: Dim ED As Integer
      Dim Adj1904 As Integer
    
      Dim YearsArray As Variant
      Dim DatesArray() As Variant
      Dim OutputArray() As Variant
      Dim x As Long, y As Long
    
      ' Fill the array. Handle 1-element arrays separately
      Select Case Application.WorksheetFunction.Count(year)
        Case 0
            Exit Function
        Case 1
            ReDim YearsArray(1, 1)
            YearsArray(1, 1) = year
        Case Else
            YearsArray = year
      End Select
    
      ReDim DatesArray(1 To UBound(YearsArray, 1))
      For x = 1 To UBound(YearsArray, 1)
    
        If Not IsDate("1/1/" & YearsArray(x, 1)) Then
            EASTER_by_NHarker = "Excel Year Limit Error"
            Exit Function
        End If
    
        G = YearsArray(x, 1) Mod 19
        C = YearsArray(x, 1) \ 100
        H = (C - C \ 4 - (8 * C + 13) \ 25 + 19 * G + 15) Mod 30
        i = H - (H \ 28) * (1 - (29 \ (H + 1)) * ((21 - G) \ 11))
        J = (YearsArray(x, 1) + YearsArray(x, 1) \ 4 + i + 2 - C + C \ 4) Mod 7
        L = i - J
        EM = 3 + (L + 40) \ 44
        ED = L + 28 - (31 * (EM \ 4))
        If ActiveWorkbook.Date1904 = True Then
          Adj1904 = 365 * 4 + 2
        End If
        DatesArray(x) = CDate(Trim((DateSerial(YearsArray(x, 1), EM, ED) - Adj1904)))
      Next
    
      EASTER_by_NHarker = Application.Transpose(DatesArray)
    
    End Function
    

    Here's what it looks like on the worksheet:

    1. Multiple Years (end year is after the start year)

    2. Single Year (start and end years are the same)