Q:

Reduce for loop execution time that returns a count

What I am trying to achieve
I have two sheets: 'dashboard' and 'temp calc'.
Dashboard has all employee details and range "N1" "N2" contain dates.
Now a macro populates employee data and generates a daywise calendar as shown in the following image
 
'temp calc' has their project details with start date end date.(the date that do not fall between n1 and n2 dates from dashboard sheet are deleted here).
So now referencing their empid from dashboard sheet, and using the first day populated in dashboard sheet i loop through the emp id in temp calc sheet and return a count for the number of projects a employee is currently working on for the particular day. as shown in the following image.

how I achieve this:
the code.....
Option Explicit
Sub Count()

' x= no of columns(dashboard calender)
' y= no of rows(dashboard emp id)
' z= no of rows(temp calc sheet emp id)

    Application.ScreenUpdating = False

   'Clear calender data
    Range("Q4").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.ClearContents

    Dim i, j, k, l, d, x, y, z, Empid As Long
    Dim currentdate, startdate, enddate As Date

    x = (Range("n2") - Range("n1")) + 1
    y = Application.WorksheetFunction.counta(Range("A:A")) - 1
    z = Application.WorksheetFunction.counta(Worksheets("Temp Calc").Range("A:A")) - 1

    For i = 1 To y Step 1  'To loop through the emp_id in dashboard.
        For j = 1 To x Step 1 'To loop through the calender in dashboard daywise.
            d = 0
            For k = 1 To z Step 1 'To loop through the emp_id i temp calc sheet.

                Empid = ActiveSheet.Cells(i + 3, 1).Value

                currentdate = Cells(3, 16 + j).Value

                startdate = Worksheets("Temp calc").Cells(k + 1, 3).Value
                enddate = Worksheets("Temp calc").Cells(k + 1, 4).Value
                If (Worksheets("Temp calc").Cells(k + 1, 1).Value) = Empid Then

                    If (currentdate >= startdate) And (currentdate <= enddate) Then     'To check whether the first column date falls within the project start and end date
                        d = d + 1

                    End If
                End If

            Next
            Worksheets("Dashboard").Cells(i + 3, j + 16) = d
        Next
    Next         
    Range("q4").Select

    Application.ScreenUpdating = True
End Sub

My problem: The code does the job,but I have two problems.

It is too slow
Sometimes the workbook will say not responding and won't do the work.I've checked it does not work in the background. I left the program running overnight and it went into not responding.

Possible solutions:

using two arrays: one array to store empid in dashboard,second array to store calendar generated in dashboard. and then compare it with data from temp calc sheet and return a count into array number 2 and write it back
the problem is I've just started reading about arrays and I am still learning
I am open to possible alternatives:

cheers,
mathew

A:

This works for me..... Hope it will be helpful for someone else with the same problem..
A big thank you to everyone who helped me with this and also for everybodys suggestions and answers.... :)
   Sub assginment_count()
    Dim a, i As Long, ii As Long, dic As Object, w, e, s
    Dim StartDate As Date, EndDate As Date
    Set dic = CreateObject("Scripting.Dictionary")
     ' use dic as a "mother dictionary" object to store unique "Employee" info.
    dic.CompareMode = 1
     ' set compare mode to case-insensitive.
    a = Sheets("temp calc").Cells(1).CurrentRegion.Value
     ' store whole data in "Temp Calc" to variable "a" to speed up the process.
    For i = 2 To UBound(a, 1)
         ' commence loop from row 2.
        If Not dic.exists(a(i, 1)) Then
            Set dic(a(i, 1)) = CreateObject("Scripting.Dictionary")
             ' set child dictionary to each unique "Emp Id"
        End If
        If Not dic(a(i, 1)).exists(a(i, 3)) Then
            Set dic(a(i, 1))(a(i, 3)) = _
            CreateObject("Scripting.Dictionary")
             ' set child child dictionary to each unique "Startdt" to unique "Emp Id"
        End If
        dic(a(i, 1))(a(i, 3))(a(i, 4)) = dic(a(i, 1))(a(i, 3))(a(i, 4)) + 1
         ' add 1(count) to a unique set of "Emp Id", "Startdt" and "Finishdt", so that it enables to count as
         ' different match even if multiple same unique set of "Emp Id", "Startdt" and "Finishdt" appears.
    Next
    With Sheets("dashboard")
        StartDate = .[N1].Value: EndDate = .[N2].Value
        With .Range("a3").CurrentRegion.Resize(, .Rows(3).Find("*", , , , xlByRows, xlPrevious).Column)
             ' finding the data range, cos you have blank column within the data range.
            .Columns("q").Resize(.Rows.count - 3, .Columns.count - 16).Offset(3).Value = 0
             ' initialize the values in result range set to "0".
            a = .Value
             ' store whole data range to an array "a"
            For i = 4 To UBound(a, 1)
                 ' commence loop from row 4.
                If dic.exists(a(i, 1)) Then
                     ' when mother dictionary finds "Employee"
                    For Each e In dic(a(i, 1))
                         ' loop each "Startdt"
                        For Each s In dic(a(i, 1))(e)
                             ' loop corresponding "Finishdt"
                            If (e <= EndDate) * (s >= StartDate) Then
                                 ' when "Startdt" <= EndDate and "Finishdt" >= StartDate
                                For ii = 17 To UBound(a, 2)
                                     ' commence loop from col.Q
                                    If (a(3, ii) >= e) * (s >= a(3, ii)) Then
                                         ' when date in the list matches to date between "Startdt" and "Finishdt"
                                        a(i, ii) = a(i, ii) + dic(a(i, 1))(e)(s)
                                         ' add its count to corresponding place in array "a"
                                    End If
                                Next
                            End If
                        Next
                    Next
                End If
            Next
            .Value = a
             ' dump whole data to a range.
        End With
    End With
End Sub

