Search Excel Sheets for dates to consolidate data by month using VBA

Question

I have an unknown number of Sheets in a workbook but each sheet shares identical formating. Each sheet represents a work week. These weeks can straddle calendar months. Each column has a row which reflects a day of the week and has a date cell. Date format is dd/mm/yr

My code currently finds the number of sheets and parses through the sheets to consolidate specific information to a summary sheet. This information is in a year to date (YTD) format.

In addition to YTD format, I need to be able to pull out the data on a calendar month basis.

Each sheet has up to 5 cells of data (one per day of the week) and two groups of up to 5 cells (ie. Route Hours and Total Hours, up to 5 entries- Mon-Fri, if with in the active month) The cells will be summed together resulting in two sums. This needs to be done for each working week in a calendar month and the total values then output to my summary sheet.

The code below is what I am using to go through each data sheet and grab YTD data. I want to add code to cover the monthly data extraction as well but I am having extreme difficulty implementing such code--I keep going in mental circles.

Dim I As Integar
Dim WS_Count As Integar
Dim ConsolidationArrayYTDTotalDailyAve() 'Array storage YTD Tot Daily Ave

WS_Count = ActiveWorkbook.Worksheets.Count ' last worksheet
ReDim ConsolidationArrayYTDTotalDailyAve(WS_Count-2)   

For I = 2 to WS_Count 'check from 2nd WS as first sheet is the summary
    ConsolidationArrayYTDTotalDailyAve(I - 2) = Worksheets(I).Name & "!R54C3:R56C8" 'Grab the data from each sheet and save in the array
Next I
Sheets("Summary").Range("B4").Consolidate sources:=(ConsolidationArrayYTDTotalDailyAve), Function:=xlAverage

I am thinking somewhat of the following design(with the do while loop to be inside the above For loop--not actual code just trying to express thought process):

Dim Im As Integer 'Same function as I when parsing through sheets
Dim FirstDay As Date 'first day of the month
Dim LastDay As Date 'last day of the month
Dim Month as Integer 'tracks active month 1 through 12
Dim RouteHrsSum As Single 'stores the sum of monthly Route Hours
Dim TotalHrsSum As Single 'stores the sum of monthly Total Hours

Month = 1 'set default month to January

Do While (ActiveCell >= FirstDay & ActiveCell <= LastDay) & Month <= 12
    For Im = 2 to WS_Count
        IF Month = 1 Then
            FirstDay = 1/1/2016 & LastDay = 31/1/2016
        ElseIF Month = 2 Then
            FirstDay = 1/2/2016 & LastDay = 29/02/2016
        ETC...
        Else
            FirstDay = 1/12/2016 & LastDay = 31/12/2016
        Action: Scan a range of cells for dates for the active month
        IF Date of Active Month found then sum cells A2, B2, C2 together, sum cells A9,B9,C9 together and write both sums to a pair of storage vairables (RouteHrsSum and TotalHrsSum respectively)
        Else
            Output RouterHrsSum & TotalHRsSum to respective cells on sheeet 1
            Month = Month + 1 'Make next month active
            'need to be able to recheck the last worksheet for a calendar month straddle and get data if so for new month's days
        Next Im 
Loop

Sample of a data worksheet: (week ending 19-Aug)

Driver Bob    Monday    Tuesday    Wednesday    Thursday    Friday    
              15-Aug    16-Aug     17-Aug       18-Aug      19-Aug
Kilometres    318       91         119          219         394
Route Hours   5.74      4          2.5          4.25        6
Total Hours   9         9          9            9           10

Sample of a data worksheet: (week ending straddling calendar months)

Driver Bob    Monday    Tuesday    Wednesday    Thursday    Friday    
              29-Aug    30-Aug     31-Aug       1-Sept      2-Sept
Kilometres    300       110        119          89          394
Route Hours   7         4          2.5          4.25        6
Total Hours   9         9          9            9           9

I feel I'm on the right track, conceptually, but I keep getting bogged down when it comes to the actual code and design. Any assistance is appreciated. I apologise if this is vague, but I cannot see the forest for the trees.

I will readily edit this question for content as greater clarity presents.

Answer 1

I think that it would be just as easy to compile the data as to use consolidate.

Sub ProcessData()
    Dim arTemp
    Dim d As Date
    Dim x As Long, y As Integer
    Dim ws As Worksheet
    Dim list As Object
    Set list = CreateObject("System.Collections.SortedList")

    For Each ws In Worksheets
        If ws.Name <> "Summary" Then
            With ws
                For y = 2 To 6
                    d = DateSerial(Year(.Cells(2, y)), Month(.Cells(2, y)), 1)
                    If list.ContainsKey(d) Then
                        arTemp = list(d)
                    Else
                        ReDim arTemp(2)
                    End If
                    arTemp(0) = arTemp(0) + .Cells(3, y)
                    arTemp(1) = arTemp(1) + .Cells(4, y)
                    arTemp(2) = arTemp(2) + 1
                    list(d) = arTemp

                Next
            End With
        End If
    Next
    With Worksheets("Summary")
        .Cells.Delete
        .Range("A1:F1") = Array("Year", "Month", "Avg. Kilometres", "Avg. Route Hours", "Sum Kilometres", "Sum Route Hours")
        For x = 0 To list.Count - 1
            d = list.GetKey(x)
            .Cells(x + 2, 1) = Year(d)
            .Cells(x + 2, 2) = Month(d)
            .Cells(x + 2, 3) = list(d)(0) / list(d)(2)
            .Cells(x + 2, 4) = list(d)(1) / list(d)(2)
            .Cells(x + 2, 5) = list(d)(0)
            .Cells(x + 2, 6) = list(d)(1)
        Next
            .Rows(x + 2).Columns("C:D").FormulaR1C1 = "=Average(R[-" & x & "]C:R[-1]C)"
            .Rows(x + 2).Columns("E:F").FormulaR1C1 = "=Sum(R[-" & x & "]C:R[-1]C)"
            .Columns("C:F").NumberFormat = "0.00"
        .Columns.AutoFit
    End With
End Sub