VBA从有条件的日期重叠网络日

Question

首先我愿意从另一个角度来做这件事。

我想计算估计的总工作时数，请参阅表 2。在另一个子中，我用 worksheetfunction.sum 计算了总工作时间（计时器 tot），用 worksheetfunction.sumif 计算了计时器 FRJ/HET。此代码不考虑重叠天数，这意味着如果日期彼此相交，它将计算 8*2(3,4,5...)（8 小时是挪威的平均工作日），而不是每个工作日 8 小时。这会弄乱估计的总时间，并且我们可能会估计每天的小时数超过 24 小时：D

我已经开始使用这段代码来减去 FRJ 和 HET 的总时间和总金额。

代码：

Sub Overlapping_WorkDays()

Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range

Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))

For Each cell_name In rng_FRJ_HET
    If cell_name = "FRJ" Then
        'Count Overlapping networkdays for FRJ
    Elseif cell_name = "HET" Then
        'Count Overlapping networkdays for HET
    End If
Next cell_name

End Sub

Sheet1 截图

Sheet2 截图

Answer 1

您需要做的就是遍历所有日期范围，并在尚未计算的情况下计算它们。来自 Microsoft Scripting Runtime 的 Dictionary 非常适合此操作（您需要在 Tools->References 中添加引用）。

Function TotalWorkDays(Optional category As String = vbNullString) As Long
    Dim lastRow As Long

    With Sheet1
        lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row

        Dim usedDates As Scripting.Dictionary
        Set usedDates = New Scripting.Dictionary

        Dim r As Long
        'Loop through each row with date ranges.
        For r = 8 To lastRow
            Dim day As Long
            'Loop through each day.
            For day = .Cells(r, 4).Value To .Cells(r, 5).Value
                'Check to see if the day is already in the Dictionary
                'and doesn't fall on a weekend.
                If Not usedDates.Exists(day) And Weekday(day, vbMonday) < 6 _
                    And (.Cells(r, 1).Value = category Or category = vbNullString) Then
                    'Haven't encountered the day yet, so add it.
                    usedDates.Add day, vbNull
                End If
            Next day
        Next
    End With
    'Return the count of unique days.
    TotalWorkDays = usedDates.Count
End Function

请注意，这将适用于在第 1 列中找到的任意类别，或者如果未传递参数，则将所有类别组合在一起。示例用法：

Sub Usage()
    Debug.Print TotalWorkDays("HET")  'Sample data prints 55
    Debug.Print TotalWorkDays("FRJ")  'Sample data prints 69
    Debug.Print TotalWorkDays         'Sample data prints 69
End Sub

您可以通过替换这两行将其转换为后期绑定（并跳过添加引用）...

    Dim usedDates As Scripting.Dictionary
    Set usedDates = New Scripting.Dictionary

...与：

    Dim usedDates As Object
    Set usedDates = CreateObject("Scripting.Dictionary")

Answer 2

据我所知，没有直接的公式可以获取重叠日期。我的做法会和你不一样。

For each unique value in rng_FRJ_HET (i.e. only FRJ and HET as per e.g.)
   Create an array with first date and last date
   Mark array index with 1 for each date in range start and end date
   Sum the array to get actual number of days
Next

因此，如果日期仍然重复，它们将在该日期的数组中标记为 1。 =====================添加了代码=== 这适用于任意数量的名称。

选项显式

Dim NameList() As String

Sub Overlapping_WorkDays()
    Dim rng_FRJ_HET As Range
    Dim cell_name As Range
    Dim startDateRng As Range
    Dim endDateRng As Range
    Dim uniqueNames As Range
    Dim stDate As Variant
    Dim edDate As Variant
    Dim Dates() As Integer

    Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
    Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
    Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))

    stDate = Application.WorksheetFunction.Min(startDateRng)
    edDate = Application.WorksheetFunction.Max(endDateRng)
    ReDim NameList(0)
    NameList(0) = ""

    For Each cell_name In rng_FRJ_HET
        If IsNewName(cell_name) Then
            ReDim Dates(stDate To edDate + 1)
            MsgBox cell_name & " worked for days : " & CStr(GetDays(cell_name, Dates))
        End If
    Next cell_name

End Sub

Private Function GetDays(ByVal searchName As String, ByRef Dates() As Integer) As Integer
    Dim dt As Variant
    Dim value As String
    Dim rowIndex As Integer

    Const COL_NAME = 1
    Const COL_STDATE = 4
    Const COL_EDDATE = 5
    Const ROW_START = 8
    Const ROW_END = 19

    With Sheet1
        For rowIndex = ROW_START To ROW_END
            If searchName = .Cells(rowIndex, COL_NAME) Then
                For dt = .Cells(rowIndex, COL_STDATE).value To .Cells(rowIndex, COL_EDDATE).value
                    Dates(CLng(dt)) = 1
                Next
            End If
        Next
    End With

    GetDays = WorksheetFunction.Sum(Dates)
End Function

Private Function IsNewName(ByVal searchName As String) As Boolean
    Dim index As Integer

    For index = 0 To UBound(NameList)
        If NameList(index) = searchName Then
            IsNewName = False
            Exit Function
        End If
    Next

    ReDim Preserve NameList(0 To index)
    NameList(index) = searchName
    IsNewName = True
End Function

Answer 3

Dictionary 方法应该是最快的。

但如果您的数据不是那么大，您可能希望采用如下“字符串”方法

Function CountWorkingDays(key As String) As Long
    Dim cell As Range
    Dim iDate As Date
    Dim workDates As String

    On Error GoTo ExitSub
    Application.EnableEvents = False
    With Sheet1
        With .Range("E7", .Cells(.Rows.Count, "A").End(xlUp))
            .AutoFilter field:=1, Criteria1:=key
            For Each cell In Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Columns(1))
                For iDate = cell.Offset(, 3) To cell.Offset(, 4)
                    If Weekday(iDate, vbMonday) < 6 Then
                        If InStr(workDates, cell.value & iDate) <= 0 Then workDates = workDates & cell.value & iDate
                    End If
                Next iDate
            Next cell
        End With
    End With

    CountWorkingDays = UBound(Split(workDates, key))
ExitSub:
    Sheet1.AutoFilterMode = False
    Application.EnableEvents = True
End Function

你可以在你的代码中使用如下

sht2.Cells(2, 7) = CountWorkingDays("FRJ")
sht2.Cells(2, 8) = CountWorkingDays("HET")

Answer 4

我想如果我这样做，我会使用 Collection 对象，因为它会保存将名称和日期转换为索引 ID。

您可以创建一个主名称集合，并为每个名称创建一个日期子集合，其键是 Excel 的日期序列号。这样可以轻松存储“使用天数”，您可以使用 .Count 属性获取总天数，也可以循环访问集合以聚合特定的 Oppgave。

代码如下所示。你可以把它放在一个模块中：

Option Explicit

Private mNames As Collection

Public Sub RunMe()

    ReadValues

    'Get the total days count
    Debug.Print GetDayCount("FRJ")
    'Or get the days count for one Oppgave
    Debug.Print GetDayCount("FRJ", "Malfil tegning form")

End Sub

Private Sub ReadValues()
    Dim v As Variant
    Dim r As Long, d As Long
    Dim item As Variant


    Dim dates As Collection

    With Sheet1
        v = .Range(.Cells(8, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 5).Value2
    End With

    Set mNames = New Collection
    For r = 1 To UBound(v, 1)
        'Acquire the dates collection for relevant name
        Set dates = Nothing: On Error Resume Next
        Set dates = mNames(CStr(v(r, 1))): On Error GoTo 0
        'Create a new dates collection if it's a new name
        If dates Is Nothing Then
            Set dates = New Collection
            mNames.Add dates, CStr(v(r, 1))
        End If
        'Add new dates to the collection
        For d = v(r, 4) To v(r, 5)
            On Error Resume Next
            dates.Add v(r, 2), CStr(d)
            On Error GoTo 0
        Next
    Next
End Sub
Private Function GetDayCount(namv As String, Optional oppgave As String) As Long
    Dim dates As Collection
    Dim v As Variant

    Set dates = mNames(namv)

    If oppgave = vbNullString Then
        GetDayCount = dates.Count
    Else
        For Each v In dates
            If v = oppgave Then GetDayCount = GetDayCount + 1
        Next
    End If

End Function