Question

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

我想计算估计的工作小时数，请参阅表2。在另一个子程序中，我使用worksheetfunction.sum和计时器FRJ / HET以及worksheetfunction.sumif计算了总工时（计时器总数）。此代码不考虑重叠天数，这意味着如果日期相互交叉，它将计算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截图

Sheet1 screenshot

Sheet2截图

Sheet2 screenshot

Answer 1

据我所知，没有直接的公式来获得重叠日期。我的方法与你的方法不同。

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 2

我认为如果我这样做，我会使用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

Answer 3

您需要做的就是遍历所有日期范围并计算它们（如果尚未计算）。 Microsoft Scripting Runtime中的Dictionary非常适合此（您需要在Tools-＆gt; 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 4

Dictionary方法应该是最快的。

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

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")

VBA与具有条件的日期重叠网络日

Sheet1截图

Sheet2截图

4 个答案: