0

我想要达到的目标

我有两张纸：“仪表板”和“临时计算”。
仪表板包含所有员工详细信息，范围“N1”“N2”包含日期。
现在一个宏填充员工数据并生成一个按日日历，如下图所示， 示例图像 “temp calc”有他们的项目详细信息和开始日期结束日期。（此处删除仪表板表中不介于 n1 和 n2 日期之间的日期） .

因此，现在从仪表板表中引用他们的 empid，并使用在仪表板表中填充的第一天，我循环遍历临时计算表中的 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. 有时工作簿会说没有响应并且无法完成工作。我已经检查过它在后台不起作用。我让程序在一夜之间运行，它没有响应。

可能的解决方案：

  1. 使用两个数组：一个数组存储仪表板中的empid，第二个数组存储仪表板中生成的日历。然后将其与临时计算表中的数据进行比较，并将计数返回到数组 2 并将其写回问题是我刚刚开始阅读有关数组的内容，我仍在学习

  2. 我对可能的替代方案持开放态度：

干杯，
马修

4

2 回答 2

2

有几个内置函数可以非常有效地做到这一点。我将在这里列出几个：

  1. 使用自动过滤器仅选择一组特定的数据（例如，对员工进行自动过滤，或对日期范围进行自动过滤等） - 然后您可以仅单步执行属于该员工的元素
  2. 对员工进行排序 - 然后您只需遍历有效的员工 ID，当您找到下一位员工时，您将开始下一个循环
  3. 使用数据透视表为您完成所有工作：创建表，员工 ID 在左侧，日期在顶部，并使用“计数”作为被评估的函数。您可以使用数据透视表中的过滤选项将其缩小到您想要的日期范围 - 或者您可以在计算数据透视表之前将员工表中的数据自动过滤到您想要的范围

这些中的任何一个都应该使您的代码足够快-我个人的偏好是选项 3...如果您不喜欢选项 3 的布局，并且不能使其“就这样”，请在隐藏的工作表并将数据从那里复制到您想要的工作表。

顺便说一句 - 做类似COUNTA("A:A"的事情可能很慢，因为这意味着要查看列中的所有 150 万个单元格。如果行是连续的，您应该能够执行以下操作：

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

或（如果不连续）

numRows = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
COUNTA(RANGE("A1", [A1].OFFSET(numRows,0)))
于 2013-07-05T13:45:20.883 回答
0

这对我有用.....希望它对其有同样问题的其他人有所帮助..非常感谢所有帮助我的人以及每个人的建议和答案.... :)

   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
于 2013-07-10T03:15:34.070 回答