VBA 与条件日期重叠的网络日
VBA overlapping networkdays from dates with a condition
首先，我愿意从另一个角度来做这件事。
我想统计预计的工作总时数，见sheet2。在另一个子程序中，我用 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 截图
据我所知，没有直接的公式可以得到重叠日期。我的方法会和你的不一样。
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
我想如果我这样做，我会使用 Collection 对象，因为它会保存将名称和日期转换为索引 ID 的过程。
您可以创建一个主要的姓名集合，并为每个姓名创建一个日期子集合，其关键字是 Excel 的日期序列号。这将使存储 'used days' 变得容易，您可以使用 .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
您需要做的就是遍历所有日期范围并计算它们（如果尚未计算）。来自 Microsoft Scripting Runtime 的 Dictionary 非常适合于此（您需要在工具 -> 参考中添加参考）。
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")
Dictionary方法应该是最快的。
但如果您的数据不是那么大，您可能希望采用如下 "string" 方法
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")
首先，我愿意从另一个角度来做这件事。
我想统计预计的工作总时数，见sheet2。在另一个子程序中，我用 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 截图
据我所知，没有直接的公式可以得到重叠日期。我的方法会和你的不一样。
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
我想如果我这样做，我会使用 Collection 对象，因为它会保存将名称和日期转换为索引 ID 的过程。
您可以创建一个主要的姓名集合，并为每个姓名创建一个日期子集合，其关键字是 Excel 的日期序列号。这将使存储 'used days' 变得容易，您可以使用 .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
您需要做的就是遍历所有日期范围并计算它们（如果尚未计算）。来自 Microsoft Scripting Runtime 的 Dictionary 非常适合于此（您需要在工具 -> 参考中添加参考）。
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")
Dictionary方法应该是最快的。
但如果您的数据不是那么大，您可能希望采用如下 "string" 方法
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")