Nsryjdtyk

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

'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