Сокращение для петлевой времени выполнения, которая возвращает количество

Question

То, что я пытаюсь достичь

У меня есть две таблицы: «панель» и «Темп» выч.
Dashboard содержит всю информацию о сотрудниках и диапазон «N1» «N2» содержит даты.
Теперь макрос заполняет данные сотрудника и генерирует ежедневный календарь, как показано на следующем изображении. «temp calc» имеет свои данные о проекте с датой окончания даты начала (дата, которая не падает между датами n1 и n2 с панели управления лист удаляются здесь).

Так что теперь, ссылаясь на их эмпирику из листа приборной панели, и используя первый день, заполненный листом панели мониторинга, я прохожу через идентификатор emp в листе temp calc и возвращаю счет для количества проектов, над которыми работник в настоящее время работает для конкретного день. как показано на следующем рисунке.

, как достичь этого:

код .....

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 

Моя проблема: код делает работу, но у меня есть две проблемы ,

1. Это слишком медленно

2. Иногда учебное пособие будет сказать, не отвечает и не будет делать work.I've проверил это не работает в фоновом режиме. Я оставил программу на ночь, и она не отвечала.

Возможные решения:

1. используя два массива: один массив для хранения EmpID в приборной панели, второй массив для хранения календаря генерируется в приборной панели. а затем сравните его с данными из таблицы temp calc и верните счет в массив номер 2 и запишите его обратно Проблема заключается в том, что я только начал читать о массивах, и я все еще учился

2. Я открыт для возможных альтернатив :

веселит,
Мэтью

Answer 1

Это работает для меня ..... Надеюсь, что это будет полезно для кого-то еще с той же проблемой .. большое спасибо всем, кто помог мне с этим, а также для Everybodys предложений и ответов .... :)

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 

Answer 2

Есть несколько встроенных функций, которые будут делать это достаточно эффективно. Есть только пара, которую я приведу здесь:

1. Используйте Autofilter для выбора только определенного набора данных (например,автофильтр на рабочем месте или автофильтр в диапазоне дат и т. д.) - тогда вы можете пройти через только элементы, принадлежащие этому сотруднику.
2. сортировать по сотруднику - тогда вы выполняете только действительные идентификаторы сотрудников, и когда вы переходите к следующему сотруднику, вы запустите следующий цикл
3. используйте сводную таблицу, чтобы сделать все для вас: создайте таблицу с идентификатором сотрудника слева, датой сверху и используйте «счет» в качестве оцениваемой функции. Вы можете использовать опцию фильтра в сводную таблицу, чтобы получить это вплоть до диапазона дат вы хотите - или вы можете Автофильтрами данные в таблице сотрудников в диапазоне вы хотите перед вычислением сводной таблицы

Любой из них должен сделать ваш код достаточно быстрым - моим личным предпочтением является вариант 3 ... И если вам не нравится макет варианта 3, и вы не можете сделать это «просто так», тогда создайте сводную таблицу в скрытом листе и скопируйте данные оттуда на нужный лист.

Как в стороне - делать такие вещи, как COUNTA("A:A", вероятно, довольно медленно, так как это означает просмотр всех 1,5 миллионов ячеек в столбце. Если строки являются смежными, вы должны быть в состоянии сделать что-то вроде:

COUNTA(RANGE("A1", [A1].End(xlDown))) 

или (если не соприкасаются)

numRows = ActiveSheet.Cells.SpecialCells(xlLastCell).Row 
COUNTA(RANGE("A1", [A1].OFFSET(numRows,0)))