減少返回計數

Question

我想實現

我有兩片循環執行時間：「儀表盤」和「臨時計算」。
儀表板包含所有員工詳細信息和範圍「N1」「N2」包含日期。
現在一個宏填充員工數據並生成如下圖所示的日曆日曆 'temp calc'的項目詳細信息包含開始日期結束日期（日期不在n1和n2日期之間）表格在這裏被刪除）。

因此，現在通過儀表板表引用他們的empid，並使用第一天填充在儀表板表中，我通過temp計算表中的emp id循環並返回一個員工當前正在爲特定天。如下圖所示。

我如何做到這一點：

代碼.....

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存儲在儀表盤，儀表板中產生的第二陣列來存儲日曆。然後將它與溫度計算表中的數據進行比較，並將計數返回到數組編號2並將其寫回 問題是我剛開始閱讀有關數組，我仍在學習

2. 我對可能的替代方法開放：

歡呼聲，
馬修

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 

Answer 2

有幾個內置的功能，這將非常有效地做到這一點。這裏只列出一對夫婦：

1. 使用自動過濾器僅選擇一組特定的數據（例如，員工上的自動過濾器或日期範圍上的自動過濾器等） - 然後您可以逐步瀏覽屬於該員工的元素
2. 排序在員工身上 - 然後您只能瀏覽有效的員工ID，並且當您到達下一個員工時開始下一個循環
3. 使用數據透視表爲您完成整個任務：創建表 ，其中員工ID在左側，日期在頂部，並使用「count」作爲正在評估的函數。您可以使用數據透視表中的過濾器選項將此數據下載到您想要的日期範圍 - 或者您可以在計算數據透視表之前將僱員表中的數據自動過濾到您想要的範圍內

任何這些應該讓你的代碼快很多 - 我的個人偏好是選項3 ...如果你不喜歡選項3的佈局，並且你不能使它「如此」，那麼在隱藏表中創建數據透視表並從那裏複製數據到你想要的工作表。

順便說一句 - 像COUNTA("A:A"這樣的事情可能會很慢，因爲這意味着要查看列中所有150萬個單元格。如果行是連續的，你應該能夠做這樣的事情：

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

或者（如果不是連續的）

​​