我尝试在并发使用许可模型中定义一个水印值。我拥有的值列表由值对组成，第一个值是登录时间戳，第二个值是注销时间戳。
我试图完成的是为每个值对设置一个计数器，告诉我与它重叠的值对的数量;最高的计数是我的水印。
数据如下:
Number Start End
1 06.10.2021 19:21:18 06.10.2021 19:35:42
2 12.10.2021 21:16:30 12.10.2021 21:30:54
3 12.10.2021 21:18:54 12.10.2021 21:18:56 'start and end value inside range of data pair (2)
4 12.10.2021 21:19:54 12.10.2021 21:22:54 'start and end value inside range of data pair (2)
5 23.10.2021 00:09:18 23.10.2021 00:23:42
6 23.10.2021 00:18:54 23.10.2021 02:33:18 'start value inside range of data pair (5)
7 23.10.2021 00:19:18 23.10.2021 00:34:42 'start value inside range of data pair (5)
到目前为止，我所拥有的代码，虽然可能很笨重，但部分工作是正确的。它循环遍历一个又一个开始日期，将其与列表中的每个数据对进行比较，并将计数器值写入定义的单元格中。它看起来像这样:
Private Sub Concurrent2_Click()
'Check concurrent use for a number of lines
Dim FirstRow As Integer 'line to start from
Dim Increment1 As Long 'variable to go next line
Dim Increment2 As Long 'variable to check previous lines
Dim c As Integer 'varible for cell value
Dim Counter As Long
Dim LastRow As Integer
FirstRow = 2 'offset
Increment1 = 0
Increment2 = 0
With Worksheets("Testdaten")
'define variable for range
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
'define range
For Counter = .Range("I" & FirstRow) To .Range("I" & LastRow)
'create loop that evaluates if a start time is between any of the other start and stop times in the selected range
'repeat until increment2 is equal to the last row in range
Do Until Increment2 = LastRow - 1
'do the comparison between the start and stop time in the selected row
If .Range("I" & FirstRow + Increment1).Value >= .Range("I" & FirstRow + Increment2).Value And _
.Range("I" & FirstRow + Increment1).Value <= .Range("J" & FirstRow + Increment2).Value Then
'add 1 to a counter if both conditions are met
c = c + 1
End If
' go to next row to compare the selected value
Increment2 = Increment2 + 1
Loop
' when finished, write value to the result cell for the value that is being evaluated
.Range("L" & FirstRow + Increment1).Value = c
' when finished with one start time value , go to next one
Increment1 = Increment1 + 1
' reset all other counters
Increment2 = 0
c = 0
Next
'done!
End With
End Sub
结果如下:
Number Start End Count
1 06.10.2021 19:21:18 06.10.2021 19:35:42 1
2 12.10.2021 21:16:30 12.10.2021 21:30:54 1
3 12.10.2021 21:18:54 12.10.2021 21:18:56 2
4 12.10.2021 21:19:54 12.10.2021 21:22:54 2
5 23.10.2021 00:09:18 23.10.2021 00:23:42 1
6 23.10.2021 00:18:54 23.10.2021 02:33:18 2
7 23.10.2021 00:19:18 23.10.2021 00:34:42 3
,而导致行号(7)是正确的,结果在数量上(4)不是(还应该3)。我认为它与这一事实有关数字的开始日期和结束日期(3)和(4)的范围内编号(2),虽然数字的结束日期(6)和(7)都是(5)数量的范围之外的。但是我不能把我的头在如何正确处理这个问题。
另一个问题是，当数据不是像这样升序排序，而是未排序时，代码会在某个点停止，我认为这也与我的求值方式有关，但我还没有开始分析第二个问题。
是否有更好的方法来评估每个开始时间的时间范围重叠?
谢谢!
将日期/时间复制到另一个工作表的单个列中并对其进行排序。然后向下扫描，开始时增加计数，结束时减少计数。
Option Explicit
Sub macro1()
Dim wb As Workbook, ws As Worksheet, wsOut As Worksheet
Dim LastRow As Long, i As Long, r As Long, c As Long
Dim s As String, ar, n As Long, max As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Set wsOut = wb.Sheets(2)
wsOut.Cells.Clear
wsOut.Columns(2).NumberFormat = "yyyy-mm-dd hh:mm:ss"
wsOut.Range("A1:D1") = Array("Number", "Date/Time", "Start/End", "Count")
r = 1
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
For c = 0 To 1
r = r + 1
wsOut.Cells(r, 1) = ws.Cells(i, 1)
' date as string 06.10.2021 19:21:18
s = Replace(ws.Cells(i, c + 2), ".", "/")
ar = Split(s, " ")
wsOut.Cells(r, 2) = DateValue(ar(0)) + TimeValue(ar(1))
wsOut.Cells(r, 3) = IIf(c, "End", "Start")
Next
Next
' sort
With wsOut.Sort
.SortFields.Clear
.SortFields.Add Key:=ws.Range("B1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange wsOut.Range("A1:C" & r)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' counts
n = 0
With wsOut
For i = 2 To r
If .Cells(i, 3) = "Start" Then
n = n + 1
Else
n = n - 1
End If
.Cells(i, "D") = n
Next
max = WorksheetFunction.max(.Columns("D:D"))
End With
MsgBox "Max count = " & max
End Sub