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.
'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