减less代码的执行时间
下面的macros用于比较员工项目date和填充在多列中的date，并给出一个员工在某一天工作的当前分配的数量。
例如： – 如果RA3 Q3：Au3充满了2013年10月的date，如q3：1月10日，r3：2月10日，s3：3月10日等等。 我的代码是将这些单独的date与来自工作表temp calc的员工开始和结束date进行比较，并通过计算员工ID来返回员工正在处理的分配数量的计数。 代码工作正常，但它需要很长时间的执行（因为有大约5万名员工），然后应用filter后，我得到的数据到工作表首先删除冗余数据，如撤回，不活跃和其他employees.also另一个过滤删除不属于我的比较范围内的员工，但员工仍然很大，而且执行时间也很大。 有人可以解释我怎么可以减less项目的执行时间和任何地方我可以清理的代码更快的执行，因为数据只会增加。
如果我无法提供足够的细节，我已经附上我的文件在下面的链接，请看看。
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 这对我有用…..而且它是非常快的….我感谢大家的帮助:)
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