уменьшить время выполнения кода

Question

ниже макрос используется для сравнения даты проекта сотрудников с днями, заполненными несколькими столбцами, и подсчета количества текущих заданий, которые сотрудник работает в определенный день.

например: - если RAnge Q3: Au3 заполнен датами октября 2013 года, , как q3: 1-й октябрь, r3: 2-й октябрь, s3: 3-й октябрь и т. Д. мой код сравнивает эти индивидуальные даты со стартовой и конечной датой сотрудников с листом temp calc и возвращает счет количества присвоений, на которые работает сотрудник, путем подсчета идентификатора сотрудника. код работает нормально, но для выполнения требуется возраст (для этого около 50 тысяч сотрудников) ive затем применяют фильтры после того, как я получу данные на листе, в первую очередь, чтобы удалить избыточные данные, такие как снятые, неактивные и другие сотрудники. другой фильтр для удаления сотрудников, которые не попадают в мой диапазон сравнения, но сотрудники по-прежнему огромны, а время извлечения также велико. может кто-то объяснить, как я могу сократить время выполнения проекта и все, где я могу очистить код для более быстрого выполнения, потому что данные будут только увеличиваться.

в случае, если я не могу предоставить достаточно подробностей, я добавил свой файл по приведенной ниже ссылке, пожалуйста, посмотрите.

https://docs.google.com/file/d/0B2CrBtuXvhrJSkgwbFZEWHYycTg/edit?usp=sharing

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 

Answer 1

это работает для меня ..... И это невероятно быстро .... я благодарю всех за помощь :)

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