Download:Mock Data.xlsx

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 (thank you to all who answer questions, you have helped build this code, whether it was just a tip or a block of code pulled and revamped). Thank you for any help you are willing to provide, even if it is just a good reference that will help me in improving it further.

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]: https://ibb.co/cJx0f9v
[Raw Data Columns]: https://ibb.co/1J5gHbf
[Tabs Example]: https://ibb.co/8m6ymY4


'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

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