Tab month tracker

Question

The code works; the problem is in the processing. I feel like the code can further improved and I believe the answer is Arrays however, my knowledge is very limited. Here, I loop through ~ 1000 columns. Each column has a start and end date; which will span from 1 day to 20 days, averaging ~ 3-5 days for each column. Upwards of 5000 lines are moved through and it shows in the speed of return. I will be adding If statements and I feel that if I add too much more where I am at that the program will crash.

I am hoping to speed it up. I believe arrays will do this however, the only array I use in here is borrowed from SO.

Tab Month Tracker

Raw Data Columns

Tabs Example

Download:Mock Data.xlsx

'Function to return array for dates between Start Date and End Date
Function GetDatesRange(dateStart As Date, dateEnd As Date) As Collection
Dim dates As New Collection
Dim currentDate As Date
currentDate = dateStart
Do While currentDate <= dateEnd

    dates.Add currentDate
    currentDate = DateAdd("d", 1, currentDate)
Loop
Set GetDatesRange = dates
End Function



'Sub to move raw data into predictable format
Sub Program()

Application.ScreenUpdating = False

Dim dateStartCell As Range, dateEndCell As Range, StartDate As Range, Cell As Range
Dim allDates As Collection
Dim currentDateSter As Variant
Dim currentDate As Date
Dim TestDate As Integer

Dim NextRow As Long
Dim AdvRow As Long

Dim Facility As String
Dim Unit As String
Dim TheDay As String
Dim TheUnit As String
Dim Pax As String

Dim Test1 As Boolean
Dim Test2 As Boolean

Set StartDate = Range("E2:E1000")

NextRow = 2

Sheets("Raw").Activate

'Evaluating Each Date in Range
For Each Cell In StartDate

Set dateStartCell = Range("E" & NextRow)
Set dateEndCell = Range("G" & NextRow)
Set allDates = GetDatesRange(dateStartCell.Value, dateEndCell.Value)

Facility = Cells(NextRow, 3)
Unit = Cells(NextRow, 2)
Pax = Cells(NextRow, 12)
    'Evaluating if the date and name already exist
    For Each currentDateSter In allDates
        currentDate = CDate(currentDateSter)
        Sheets(MonthName(Month(currentDate), True) & Year(currentDate)).Activate


        AdvRow = 3
        PropRow = Empty
        Test1 = False
        Test2 = False
        'evaluating if the date and name already exists if it does, and determines row for data entry
        'eventually end up writing over data if it already exists however, column C has 125 unique possibilities
        'that will fill another column in the month tabs
        Do
        AdvRow = AdvRow + 1
        PropRow = AdvRow

        TheDay = Cells(AdvRow, 1)
        TheUnit = Cells(AdvRow, 2)

            If TheDay = Day(currentDate) And TheUnit = Unit Then
            Test1 = True
            Else: Test1 = False
            End If

            If TheDay = TheUnit Then
            Test2 = True
            Else: Test2 = False
            End If

        Loop Until Test1 = True Or Test2 = True



    Cells(PropRow, 2).Value = Unit
    Cells(PropRow, 1).Value = Day(currentDate)
    Cells(PropRow, 3).Value = Pax




    Sheets("Raw").Activate

    Next currentDateSter

NextRow = NextRow + 1  
Next Cell
Application.ScreenUpdating = True
End Sub

Answer 1

Editor Options

The first thing that I would recommend is adjusting your VBEditor options.

Checking Require Variable Declaration will automatically put Option Explicit at the top of newly created code modules. This makes it easier to clean up code as you modify it and catch undeclared variables, such as, PropRow.

Unchecking Auto Syntax Check will prevent the Syntax Error MsgBox from appearing will you are writing your code. You will still know that there is a syntax error because the text is red but you will not have to stop to click the message.

Download Rubberduck VBA: UserForm1.Show and use it's code formatting tool. This tool will not only save a ton of time in formatting but will help catch unclosed blocks of code.

Data Typing

Using the correct data type is crucial to writing solid code. It will prevent unintended bugs from creeping in and improve the overall performance of the code. TheDay should be typed as Long because it will always be an Integer. Note: There is no advantage to using a smaller data type, such as: Byte or Integer. It looks like TheUnit should probably be long also bit that might because of the dummy data.

Dynamic Ranges

Using Dynamic Ranges Range("E2", Range("E" & Rows.Count).End(xlUp)) over staatic ranges Set StartDate = Range("E2:E1000") will prevent you from having to update the code as rows are added and optimize the code as the rows are deleted.

Loops

If you are going to iterate over each cells in the range then you should use the Cell object. Resolving the Cell is not free. It is causing the CPU to do extra work.

For Each Cell In startDate

Here is how you should use this loop:

    Set dateStartCell = Cell.Offset(0, 4).Value
    Set dateEndCell = Cell.Offset(0, 6).Value

Otherwise just use a standard For Loop.

For r  = 2 to Range("E" & Rows.Count).End(xlUp).Row

In many cases it makes sense to have another function return a collection and iterate over it. After all, the fewer tasks that a subroutine performs the easier it is to test. This is not one of those cases.

For Each currentDateSter In allDates

Basically, all the collection is used for is to start an iteration at the start date and add 1 to until you reach the end date. Not only can this be accomplished a lot cheaper by using a standard For Loop but it makes the more condense and easier to read.

For dateOf = dateStartCell.Value to dateEndCell.Value

Selecting and Activating

It is rarely necessary to Select or Activate an Object. It is much better to fully qualify your Objects and refer to them directly. This is the biggest slow down in your code.

Watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)

If Statements

I prefer to make direct boolean assignments over the bulkier If blocks.

Test1 = TheDay = Day(currentDate) And TheUnit = Unit
Test2 = TheDay = TheUnit

Test2 is misleading. Its true function is to test whether or not Cells(AdvRow, 2) is empty.

Test1 and Test2 are not very descriptive names. I would prefer dataMatched and emtpyRow but would have eliminated both variables by using the code below.

Loop Until (TheDay = Day(currentDate) And TheUnit = Unit) Or Cells(AdvRow, 2) = ""

Raw Data: Deleted Rows

Deleted rows in the Raw Data will not reflect in the monthly reports. This could lead to big problems and should be addressed.

Refactored Code

This code ran 95% faster the the original. The code could further be improved by using arrays for each month's data but that is way outside the scope of this website.

Sub Program2()
    Dim t As Double: t = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim data As Variant
    With Worksheets("Raw")                            'Load the data into an Array
        data = .Range("A2:N2", .Cells(.Rows.Count, "E").End(xlUp)).Value
    End With

    Dim dateOf As Date
    Dim r1 As Long

    For r1 = 1 To UBound(data)
        For dateOf = data(r1, 5) To data(r1, 7)
            Dim wsMonth As Worksheet, wsName As String

            If wsName <> Format(dateOf, "mmmyyyy") Then
                wsName = Format(dateOf, "mmmyyyy")
                Set wsMonth = Worksheets(wsName)
            End If

            With wsMonth
                Dim r2 As Long
                For r2 = 4 To .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                    Dim TheDay As Long
                    Dim TheUnit As Long
                    Dim Pax As String
                    TheDay = Day(dateOf)
                    TheUnit = data(r1, 2)
                    Pax = data(r1, 12)
                    If (.Cells(r2, 1).Value = TheDay And .Cells(r2, 2).Value = TheUnit) Then
                        .Cells(r2, 3).Value = Pax
                        Exit For
                    ElseIf .Cells(r2, "A").Value = "" Then
                        .Cells(r2, 1).Value = TheDay
                        .Cells(r2, 2).Value = TheUnit
                        .Cells(r2, 3).Value = Pax
                        Exit For
                    End If
                Next
            End With
        Next
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Debug.Print Round(Timer - t, 2)
End Sub

Addendum

In order to speed up the code I would use arrays to write the data to each month in one operation and dictionaries because of their lightning fast look-up speed. These references will help:

• Excel VBA Introduction Part 39 - Dictionaries
• Excel VBA Introduction Part 25 - Arrays

Answer 2

There are many areas of improvement in this coding.

A most important part of code hygiene is proper indenting, and always use Option Explicit.

Also, name your variables to something meaningful. For example, you use StartDate, but it is not a date (which the name implies), but a range.

You comment that your first function returns an Array, but it actually returns a Collection. Arrays are ordered, Collections are not, particularly in VBA.

You have some Boolean anti-patterns happening:

If TheDay = Day(currentDate) And TheUnit = Unit Then
Test1 = True
Else: Test1 = False  ' No need to run things onto a single line, especially if this is inconsistent with the other code.
End If

Can simply be:

Test1 = (TheDay = Day(currentDate)) And (TheUnit = Unit ) ' perhaps "FindMatch" is better descriptive name.

You set AdvRow and PropRow (what are these anyway - proper naming?) relative to each other within the loop, but you don't change either in that loop - so a single variable (AdvRow) will suffice.

You don't error check to ensure that the data you are reading is the right form - what happens if the data sheet does not exist, or that cell that is read is not a date?

You use NextRow while in a loop - but you already access a cell in the loop that tells you what the row is. This is one variable that can be dropped. And you are using NextRow as the CurrentRow - this is another example of a confusing variable name.

A big performance hit will come from having three nested loops, but also accessing each cell individually within those loops. Each time you make the program switch from looking at the VBA to looking at the Excel ranges is a cost in performance - this is why taking a range and putting it into an array improves efficiency.

'Function to return Collection of dates between Start Date and End Date
'**** You don't check to see if Start comes before End - what does it mean if they are the wrong way round?
Function GetDatesRange(dateStart As Date, dateEnd As Date) As Collection
Dim dates As New Collection
Dim currentDate As Date
    currentDate = dateStart
    Do While currentDate <= dateEnd
        dates.Add currentDate
        currentDate = DateAdd("d", 1, currentDate)
    Loop
    Set GetDatesRange = dates
End Function

'Sub to move raw data into predictable format
Sub Program()
Dim rawData As Variant
Dim currentRow As Long
    Application.ScreenUpdating = False
    With Sheets("Raw")
        rawData = .Range(Union(.Range("E2:E1000"), .Range("G2:G1000"), .Range("C2:C1000"), .Range("B2:B1000"), .Range("L2:L1000"))).Value
    End With

    'will be a more efficient way of setting the array, but this will do for now
    ' 0..998, 0..4 array - datestart, dateend, facility, unit, pax

    'Removes the following code:
        'Set StartDate = Range("E2:E1000")
        'NextRow = 2
        'Sheets("Raw").Activate
        'For Each Cell In StartDate
        'Set dateStartCell = Range("E" & NextRow)
        'Set dateEndCell = Range("G" & NextRow)

    For currentRow = LBound(rawData, 1) To UBound(rawData, 1)
        Dim allDates As Collection
        Dim currentDateSter As Variant
        'Set allDates = GetDatesRange(dateStartCell.Value, dateEndCell.Value)
        Set allDates = GetDatesRange(CDate(rawData(currentRow, 0)), CDate(rawData(currentRow, 0)))

        'Following code is no longer necessary
'            Facility = Cells(NextRow, 3)
'            Unit = Cells(NextRow, 2)
'            Pax = Cells(NextRow, 12)

    'Evaluating if the date and name already exist
        For Each currentDateSter In allDates
            Dim checkSheet As Worksheet ' not sure what to call this
            Dim currentDate As Date
            Dim advRow As Long
            currentDate = CDate(currentDateSter) ' what if this is not a date?
            Set checkSheet = Sheets(MonthName(Month(currentDate), True) & Year(currentDate))

            advRow = 3
            'evaluating if the date and name already exists if it does, and determines row for data entry
            'eventually end up writing over data if it already exists however, column C has 125 unique possibilities
            'that will fill another column in the month tabs
            Do
                Dim isMatch As Boolean ' Test1
                Dim isOffsetMatch As Boolean ' Test2
                Dim theDay As String
                Dim theUnit As String
                advRow = advRow + 1
                'PropRow = AdvRow

                theDay = checkSheet.Cells(advRow, 1) ' fully qualified access to cells - no ambiguity
                theUnit = checkSheet.Cells(advRow, 2)
                isMatch = (theDay = Day(currentDate)) And (theUnit = rawData(currentRow, 3))
                isOffsetMatch = (theDay = theUnit)
            Loop Until isMatch Or isOffsetMatch
            checkSheet.Cells(advRow, 2).Value = rawData(currentRow, 3)
            checkSheet.Cells(advRow, 1).Value = Day(currentDate)
            checkSheet.Cells(advRow, 3).Value = rawData(currentRow, 4)
        Next currentDateSter
    Next currentRow
    Application.ScreenUpdating = True
End Sub

Removing all my additional comments in Program gives you:

'Sub to move raw data into predictable format
Sub Program()
Dim rawData As Variant
Dim currentRow As Long
    Application.ScreenUpdating = False
    With Sheets("Raw")
        rawData = .Range(Union(.Range("E2:E1000"), .Range("G2:G1000"), .Range("C2:C1000"), .Range("B2:B1000"), .Range("L2:L1000"))).Value
    End With
    For currentRow = LBound(rawData, 1) To UBound(rawData, 1)
        Dim allDates As Collection
        Dim currentDateSter As Variant
        Set allDates = GetDatesRange(CDate(rawData(currentRow, 0)), CDate(rawData(currentRow, 0)))
    'Evaluating if the date and name already exist
        For Each currentDateSter In allDates
            Dim checkSheet As Worksheet ' not sure what to call this
            Dim currentDate As Date
            Dim advRow As Long
            currentDate = CDate(currentDateSter) ' what if this is not a date?
            Set checkSheet = Sheets(MonthName(Month(currentDate), True) & Year(currentDate))

            advRow = 3
            'evaluating if the date and name already exists if it does, and determines row for data entry
            'eventually end up writing over data if it already exists however, column C has 125 unique possibilities
            'that will fill another column in the month tabs
            Do
                Dim isMatch As Boolean ' Test1
                Dim isOffsetMatch As Boolean ' Test2
                Dim theDay As String
                Dim theUnit As String
                advRow = advRow + 1
                theDay = checkSheet.Cells(advRow, 1) ' fully qualified access to cells - no ambiguity
                theUnit = checkSheet.Cells(advRow, 2)
                isMatch = (theDay = Day(currentDate)) And (theUnit = rawData(currentRow, 3))
                isOffsetMatch = (theDay = theUnit)
            Loop Until isMatch Or isOffsetMatch
            checkSheet.Cells(advRow, 2).Value = rawData(currentRow, 3)
            checkSheet.Cells(advRow, 1).Value = Day(currentDate)
            checkSheet.Cells(advRow, 3).Value = rawData(currentRow, 4)
        Next currentDateSter
    Next currentRow
    Application.ScreenUpdating = True
End Sub

Of course, there may be some other logic paths, or even, perhaps, using Excel native functions that could help refine the problem.

I haven't been able to test the code (naturally), but it does compile in VBA.