ID Batches of Time Events within x seconds of each other

[JonRowland]

Hi,

I'm trying to work out the best way to solve a problem. I have a worksheet containing thousands of timed events, sorted in date/time order. Within this date there will be some batch events which occured with a short period. What I would like is to somehow hightlight or similar periods where there are a series of 5 or more events all within say a period 10 seconds or less of each other.

For examle the data (cols A=Date , B = Time) below I would want those in red highlight (probably with a reference in the LastCol +1)

01/01/2022 10:44:01
01/01/2022 10:44:03
01/01/2022 10:44:05
01/01/2022 10:44:07
01/01/2022 10:44:10
01/01/2022 10:45:00
01/01/2022 10:45:02
01/01/2022 10:54:11
01/01/2022 10:54:18
01/01/2022 10:54:23
01/01/2022 10:54:25
01/01/2022 10:54:29
01/01/2022 11:00:00

I'm thinking VBA for quickness but struggling to think how I'd do this. I think Do...While whislt the difference is <10 seconds between the times - but not sure. Any suggestions to get me start would be great.

 

[Akuini]

@JonRowland
Try this:

Sub JonRowland_2()
Dim i As Long, j As Long, k As Long, n As Long, ub As Long
Dim va, vb

Application.ScreenUpdating = False

rc = ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1 'last column + 1

vb = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
ub = UBound(vb, 1)
ReDim va(1 To ub, 1 To 1)

For i = 1 To ub
    va(i, 1) = vb(i, 1) + vb(i, 2)
Next

va(ub, 1) = CDate("1-1-2100")

For i = 2 To UBound(va, 1) - 5   'data start at row 2
    j = i:    k = i:    n = 1
    
    Do
        
        If DateDiff("s", va(j, 1), va(j + 1, 1)) < 10 Then
            j = j + 1:   n = n + 1
        Else
            If n > 4 Then
                Range(Cells(k, "A"), Cells(j, "B")).Font.Color = vbRed
                Range(Cells(k, rc), Cells(j, rc)).Value = "x"            'put "x" in last col+1
            End If
            Exit Do
        End If
        
     
     Loop While j < UBound(va, 1)
    
Next

Application.ScreenUpdating = True

End Sub

Book1
	A	B	C	D	E
1	date	time		something
2	01/01/2022	10.44.01			x
3	01/01/2022	10.44.03			x
4	01/01/2022	10.44.05			x
5	01/01/2022	10.44.07			x
6	01/01/2022	10.44.10			x
7	01/01/2022	10.45.00
8	01/01/2022	10.45.02
9	01/01/2022	10.54.11			x
10	01/01/2022	10.54.18			x
11	01/01/2022	10.54.23			x
12	01/01/2022	10.54.25			x
13	01/01/2022	10.54.29			x
14	01/01/2022	11.00.00
Sheet3

 

[JonRowland]

@Akunini
Thank you that does exactly what I wanted.

Thank you.

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.

 

[JonRowland]

@Akuini - one little extra would be to add a counter. I've tried to work out where it would be best to place it but have failed. Can you help?

 

[Akuini]

one little extra would be to add a counter.

Try:

Sub JonRowland_2()
Dim i As Long, j As Long, k As Long, n As Long, ub As Long, h As Long
Dim va, vb

Application.ScreenUpdating = False

rc = ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1 'last column + 1

vb = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
ub = UBound(vb, 1)
ReDim va(1 To ub, 1 To 1)

For i = 1 To ub
    va(i, 1) = vb(i, 1) + vb(i, 2)
Next

va(ub, 1) = CDate("1-1-2100")

For i = 2 To UBound(va, 1) - 5   'data start at row 2
    j = i:    k = i:    n = 1
    
    Do
        
        If DateDiff("s", va(j, 1), va(j + 1, 1)) < 10 Then
            j = j + 1:   n = n + 1
        Else
            If n > 4 Then
                Range(Cells(k, "A"), Cells(j, "B")).Font.Color = vbRed
                h = h + 1
                Range(Cells(k, rc), Cells(j, rc)).Value = "x-" & Format(h, "000")           'put "x" in last col+1
            End If
            Exit Do
        End If
        
     
     Loop While j < UBound(va, 1)
    
Next

Application.ScreenUpdating = True

End Sub

 

[JonRowland]

@Akuini​

Thanks but doesn't give the result I was looking for. Works for the first loop for range is tagged x-001 but as your loop restarts and then steps through row+1 etc means it ends up with X-001,X-002,X-003 where I was hoping for just X-001 then a new series of X-002

So I made a little change and seems to work which appears to work

<code>
For i = 2 To UBound(va, 1) - 5 'data start at row 2
j = i: k = i: n = 1

Do

If DateDiff("s", va(j, 1), va(j + 1, 1)) < 10 Then
j = j + 1: n = n + 1
Else
If n > 4 Then
Range(Cells(k, "A"), Cells(j, "B")).Font.Color = vbRed
h = h + 1
Range(Cells(k, rc), Cells(j, rc)).Value = "x-" & Format(h, "000") 'put "x" in last col+1
i = i + j ' Increment i by the last in the series range "J"
End If
Exit Do
End If
</code>

So in the image C is your original code and D is my slight amendment but guessing I am needing some confirmation that won't miss things as the original code you kindly provided seems to step through.

 

[JonRowland]

Opps that change didn't work

I should have used

 i = j

 

[Akuini]

So in the image C is your original code and D is my slight amendment

Are you sure?
Here's the result using my code in post #6.
Isn't it what you want?

Book1
	A	B	C	D	E
1	date	time		something
2	44562	0.447234			x-001
3	44562	0.447257			x-001
4	44562	0.44728			x-001
5	44562	0.447303			x-001
6	44562	0.447338			x-001
7	44562	0.447917
8	44562	0.44794
9	44562	0.454294			x-002
10	44562	0.454375			x-002
11	44562	0.454433			x-002
12	44562	0.454456			x-002
13	44562	0.454502			x-002
14	44562	0.458333
Sheet1