Identify value between two other values in a list

user_15758048 0
Viewed 56

I try to define a watermark value in a concurrent use license model. The List of values I have consists of value pairs, the first value being the login timestamp and the second value being the logout timestamp.

What I try to accomplish is a counter for each value pair that tells me the number of value pairs with which it overlaps; the highest count is my watermark.

The data look like this:

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)

The code I have until now, chunky as it probably is, does part of the job right. It loops though one start date after another, compares it to each data pair in the list, and writes a counter value into a defined cell. It looks like this:

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

The result looks like this:

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

So, while the result in line number (7) is correct, the result in number (4) isn't (it should also be 3). I assume it has something to do with the fact that the start date AND the end date in numbers (3) and (4) are inside of the range of number (2), while the end date of numbers (6) and (7) are both outside of the range of number (5). But I cannot get my head around how to get this right.

Another problem is that when the data are not sorted ascending like this, but are unsorted, the code just stops at some point, which I assume also has something to do with the way I evaluate, but I have not begun to analyze this second problem.

Is there a better way to evaluate the time range overlaps for each start time?

Thanks!

match overlap vba excel
1 Answers

Copy the date/times to a single column on another sheet and sort them. Then scan down increasing count on Start and decreasing on End.

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
user_127045930
Related