Gfrktyl

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

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

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.