2

I'd like to determine if the dates in Column B fall between two dates (the first day of month m year n and the last day of month m-1 year n+1) in several periods. For example, does 9/20/2013, a cell value in column B, fall between:

7/1/2010 and 6/30/2011
7/1/2011 and 6/30/2012
7/1/2012 and 6/30/2013
7/1/2013 and 6/30/2014
7/1/2015 and 6/30/2016

If True then a cell value in the same row of column C will contain the year of the end period where the date falls (in this case 2014) and will return a blank cell if False. Below is the data set in column B that I need to examine:

9/11/2013
8/20/2015
8/22/2013
8/31/2001
(Blank cell)
8/31/2009
AAA
9/3/2013
(Blank cell)
9/25/2011
9/30/2013
10/10/2012
Anna
10/4/2015

First I examined with the following code:

Sub CheckMyYear1_Click()
Dim i As Long, j As Long, Last_Row As Long, Period As Long
T0 = Timer

Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
Period = 5


For j = 2 To Last_Row
    For i = 1 To Period
        Begin_Period = DateSerial(Year(Date) - i, Month(Date), 1)
        End_Period = DateSerial(Year(Date) - i + 1, Month(Date), 0)

        If Cells(j, "B") >= Begin_Period And Cells(j, "B") <= End_Period Then
            Cells(j, "C") = Year(End_Period)
            Exit For
        End If
    Next i

    If Cells(j, "C") = "" Then
        Cells(j, "C") = "Out of Period"
        Cells(j, "C").Font.Color = RGB(226, 107, 10)
    End If

    If Cells(j, "B") = "" Then
        Cells(j, "C") = "No Data"
        Cells(j, "C").Font.Color = vbRed
    ElseIf IsDate(Cells(j, "B").Value) = False Then
        Cells(j, "C") = "Not Date"
        Cells(j, "C").Font.Color = vbRed
    End If

Next j
Range("C2:C" & Last_Row).Copy

InputBox "The runtime of this program is ", "Runtime", Timer - T0
End Sub

It worked fine and returned the correct outputs. To improve the performance since the size of data set could be large, I stored the data set in an array and looped through the array to examine each of its elements. Here is the code I used:

Sub CheckMyYear2_Click()
Dim i As Long, j As Long, Last_Row As Long, Period As Long
T0 = Timer

Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
Period = 5

ReDim MyDate(2 To Last_Row, 1 To 1)
ReDim MyYear(2 To Last_Row, 1 To 1)
MyDate = Range("B2:B" & Last_Row).Value

For j = 2 To Last_Row
    For i = 1 To Period
        Begin_Period = DateSerial(Year(Date) - i, Month(Date), 1)
        End_Period = DateSerial(Year(Date) - i + 1, Month(Date), 0)

        If MyDate(j, 1) >= Begin_Period And MyDate(j, 1) <= End_Period Then
            MyYear(j, 1) = Year(End_Period)
            Exit For
        End If
    Next i

    If MyYear(j, 1) = "" Then
        MyYear(j, 1) = "Out of Period"
        Cells(j, "C").Font.Color = RGB(226, 107, 10)
    End If

    If MyDate(j, 1) = "" Then
        MyYear(j, 1) = "No Data"
        Cells(j, "C").Font.Color = vbRed
    ElseIf IsDate(MyDate(j, 1).Value) = False Then
        MyYear(j, 1) = "Not Date"
        Cells(j, "C").Font.Color = vbRed
    End If

Next j
Range("C2:C" & Last_Row).Value = MyYear
Range("C2:C" & Last_Row).Copy

InputBox "The runtime of this program is ", "Runtime", Timer - T0
End Sub

The run-time error '9' occurred using the above code. I then hit F8 to know where did the arrow point at, but the arrow didn't point at any lines.

Does anyone here know how to fix the error? I'm also interested in knowing the better way to do the task above.

5
  • [...] but the arrow didn't point at any lines. - so you know which procedure is throwing the error. Good thing it's not 5K lines of code.... go to the VBE settings and select "Break on all errors", you probably have another option set. That will break on the line that throws the error. Then add On Error GoTo ErrHandler at the top, and an ErrHandler: label at the bottom, preceded by Exit Sub and followed by Stop and then Resume. When the error occurs, the cursor should be on the Stop keyword; F8 to the Resume keyword, and another F8 to jump to the exact statement that blew up. Commented Jul 21, 2016 at 8:15
  • @Mat'sMug I'm sorry, but I'm not familiar with using an Error Handler. I followed your advice but I'm confused about the Exit Sub and putting the ErrHandler: Commented Jul 21, 2016 at 8:23
  • 1
    See here for error handling tips. Commented Jul 21, 2016 at 8:32
  • There is an remnant in ElseIf IsDate(MyDate(j, 1).Value) = False Then. MyDate(j, 1) is no more a range object. So it has not a value property. Should be ElseIf IsDate(MyDate(j, 1)) = False Then Commented Jul 21, 2016 at 8:44
  • @AxelRichter Sorry, I've actually changed that in my VBE but the error still occurs. Thanks for pointing that out Commented Jul 21, 2016 at 8:46

1 Answer 1

5

Your problem is that assigning a range to a dynamic array will change the lower bound of each dimension to 1, even if you had used ReDim to set it to something else. So although this:

ReDim MyDate(2 To Last_Row, 1 To 1)

gives you an array sized as specified, as soon as you do this:

MyDate = Range("B2:B" & Last_Row).Value

Your array is actually MyDate(1 to Last_Row - 1, 1 to 1)

Sign up to request clarification or add additional context in comments.

11 Comments

"{...} even if you had used ReDim to set it to something else" ...and even if Option Base 1 isn't specified and implicitly-sized arrays have a base of 0. Gotta ♥ VBA!
It works. Thanks. But I have 2 questions. (1) Since the lower bound automatically changes and it's only an 1-D array, can I declare the array as MyDate(Last_Row - 2) since the element starts from 0? (2) Why it runs slower than the CheckMyYear1_Click? I thought using array suppose to make program runs faster.
You don't need to declare it as an array at all - just declare it as Variant and it will be sized when you assign it. A multi-cell Range object will always give you a 2D array.
@Anastasiya-Romanova 秀: "I thought using array suppose to make program runs faster." It will. But with this small amount of data it will not be visible. There the coloring of the font, which must be done within cells, will require the most of the time.
@Anastasiya-Romanova秀 As I said earlier, it is always a 2D array.
|

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.