How to find the maximum consecutive repeated value on the bases of two column in VBA , Excel

[susheeltyagi]

Hi,
I need the expert help in VBA as I am new. Actually I am looking for Vba code for Consecutive Count on the bases of two column (Serial Number and Alert Code) on button click event. The Column row are not fixed (dynamically change). The Consecutive count is maximum repeat count for Alert Code per Serial number. This should display in output worksheet as per max repeat Alert count per Serial number


Input Worksheet:

Expected Output :

The repeat count work as below pattern from Input sheet (Just for reference only).

 

[susheeltyagi]

Please help me. As mine current source code as below but this does not reference the 1st Column Serial Number (This only work for One column like AlertCode) I need the ConsecutiveCount per serial number bases (Alert Count Reset for new serial number):

Sub ConsecutiveCount()
      Dim lr As Long, c As Range, a As Long
    Application.ScreenUpdating = False
    lr = Worksheets("Count2").Cells(Rows.Count, 1).End(xlUp).Row
    For Each c In Range("B2:B" & lr)
        If c.Value <> c.Offset(1).Value Then
            a = Cells(c.Row, 3).End(xlUp).Row
'            Range(Cells(c.Row, 4), Cells(c.Row, 4).End(xlUp).Offset(1)).Value = c.Row - a
            Cells(c.Row, 3).Value = c.Row - a
        Else
        End If
    Next c
    Application.ScreenUpdating = True
End Sub

Current Output (Serial number not included) :

 

[Alex Blakenburg]

See if this works for you.

Sub ConsecutiveCount()

    Dim srcLastRow As Long, cntConsec As Long, i As Long
    Dim rng As Range
    Dim srcArr() As Variant
    Dim srcSht As Worksheet
    Dim destsht As Worksheet
    Dim destArr() As Variant
    Dim combID As String
    Dim splitID As Variant
    
    Application.ScreenUpdating = False
    
    Set srcSht = Worksheets("Input")
    Set destsht = Worksheets("Output")
    
    With srcSht
        srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1     ' include 1 blank line
        srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
    End With
    
    Dim dict As Object
    Dim dKey As Variant
    Set dict = CreateObject("Scripting.dictionary")
    
    cntConsec = 0
    
    For i = LBound(srcArr) To UBound(srcArr)
        cntConsec = cntConsec + 1
        If i <> UBound(srcArr) Then
            If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
                combID = srcArr(i, 1) & "|" & srcArr(i, 2)
                If dict.Exists(combID) Then
                    ' check if sum is more
                    If dict(combID) < cntConsec Then     ' If new max for combination
                         dict(combID) = cntConsec
                    End If
                Else
                    ' add to dictionary
                    dict(combID) = cntConsec
                    
                End If
                    cntConsec = 0
            End If
        End If
    
    Next i
    
    ReDim destArr(1 To dict.Count, 1 To 3)
    i = 0
    For Each dKey In dict.keys
        splitID = Split(dKey, "|")
        i = i + 1
        destArr(i, 1) = splitID(0)
        destArr(i, 2) = splitID(1)
        destArr(i, 3) = dict(dKey)
    Next dKey
   
    destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr

    Application.ScreenUpdating = True

End Sub

 

[susheeltyagi]

See if this works for you.

Sub ConsecutiveCount()

    Dim srcLastRow As Long, cntConsec As Long, i As Long
    Dim rng As Range
    Dim srcArr() As Variant
    Dim srcSht As Worksheet
    Dim destsht As Worksheet
    Dim destArr() As Variant
    Dim combID As String
    Dim splitID As Variant
   
    Application.ScreenUpdating = False
   
    Set srcSht = Worksheets("Input")
    Set destsht = Worksheets("Output")
   
    With srcSht
        srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1     ' include 1 blank line
        srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
    End With
   
    Dim dict As Object
    Dim dKey As Variant
    Set dict = CreateObject("Scripting.dictionary")
   
    cntConsec = 0
   
    For i = LBound(srcArr) To UBound(srcArr)
        cntConsec = cntConsec + 1
        If i <> UBound(srcArr) Then
            If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
                combID = srcArr(i, 1) & "|" & srcArr(i, 2)
                If dict.Exists(combID) Then
                    ' check if sum is more
                    If dict(combID) < cntConsec Then     ' If new max for combination
                         dict(combID) = cntConsec
                    End If
                Else
                    ' add to dictionary
                    dict(combID) = cntConsec
                   
                End If
                    cntConsec = 0
            End If
        End If
   
    Next i
   
    ReDim destArr(1 To dict.Count, 1 To 3)
    i = 0
    For Each dKey In dict.keys
        splitID = Split(dKey, "|")
        i = i + 1
        destArr(i, 1) = splitID(0)
        destArr(i, 2) = splitID(1)
        destArr(i, 3) = dict(dKey)
    Next dKey
  
    destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr

    Application.ScreenUpdating = True

End Sub

Hi Alex mind blowing.. It's working perfectly... You are Great..

 

[Alex Blakenburg]

Glad I could help. Thanks for the feedback.

 

[JEC]

Nice! I also have a solution which keeps everything within the dictionary

Sub jec()
Dim ar, a As Variant, i As Long, k As String
 ar = Cells(1, 1).CurrentRegion
 
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(ar)
      k = ar(i, 1) & ar(i, 2)
      If Not .exists(k) Then
        .Item(k) = Array(ar(i, 1), ar(i, 2), 1, 1)
      Else
         a = .Item(k)
         If ar(i, 2) = ar(i - 1, 2) Then
            a(3) = a(3) + 1
            If a(3) > a(2) Then a(2) = a(3)
           .Item(k) = a
         Else
            a(3) = 1
           .Item(k) = a
        End If
     End If
   Next
 Cells(2, 10).Resize(.Count, 3) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[Alex Blakenburg]

@JEC, thank you for sharing. I worked through your solution and I am pretty sure that this line
If ar(i, 2) = ar(i - 1, 2) Then
Needs to be modified to be this:
If ar(i, 2) = ar(i - 1, 2) And ar(i, 1) = ar(i - 1, 1) Then
I got erroneous results if Column A changed but Column B didn't.

In working through it, I wanted to use the watch window so wanted to shorten the object name and made this change:

 Dim dict As Object
 Set dict = CreateObject("scripting.dictionary")
 'With CreateObject("scripting.dictionary")
 With dict

If I run it in full it still runs but if I step through it, I get an error 13 type mismatch on the line below, any thoughts on why that might happen ?
a(3) = 1

My test data & results:

20220106 VBA Dictionary Count Max Consecutive.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	SerialNumber	AlertCode		SerialNumber	AlertCode	MaxConsecutiveCount	<----Expecting			JEC Code
2	110001	1001		110001	1001	3				110001	1001	5
3	110001	1001		110001	2201	5				110001	2201	5
4	110001	2201		990001	1001	4				990001	1001	5
5	110001	2201		110001	3001	9				110001	3001	9
6	110001	2201		220002	1001	3				220002	1001	3
7	110001	2201		220002	2201	2				220002	2201	2
8	110001	2201		220002	3301	1				220002	3301	1
9	990001	1001
10	110001	1001
11	110001	1001
12	110001	1001
13	990001	1001
14	990001	1001
15	990001	1001
16	990001	1001
17	110001	2201
18	110001	2201
19	110001	3001
20	110001	3001
21	110001	3001
22	110001	3001
23	110001	3001
24	110001	3001
25	110001	3001
26	110001	3001
27	110001	3001
28	220002	1001
29	220002	1001
30	220002	1001
31	220002	2201
32	220002	2201
33	220002	3301
Input

 

[JEC]

Yes you are correct, that line had to be changed! Thanks!

How did you declare variable a? It is weird that it errors, I tried to step through and didn't get the error. Here the small adaption you correctly suggested:

Does it error that way?

Sub jec()
 Dim ar, a As Variant, i As Long, k As String
 ar = Cells(1, 1).CurrentRegion
 
 With CreateObject("scripting.dictionary")
   For i = 2 To UBound(ar)
      k = ar(i, 1) & ar(i, 2)
      If Not .exists(k) Then
        .Item(k) = Array(ar(i, 1), ar(i, 2), 1, 1)
      Else
         a = .Item(k)
         If ar(i, 2) = ar(i - 1, 2) And ar(i, 1) = ar(i - 1, 1) Then
            a(3) = a(3) + 1
            If a(3) > a(2) Then a(2) = a(3)
         Else
            a(3) = 1
         End If
         .Item(k) = a
     End If
   Next
 Cells(2, 15).Resize(.Count, 3) = Application.Index(.items, 0, 0)
 End With
End Sub

 

[Alex Blakenburg]

Hopefully I won't forget that any time soon.
The Error 13 Type Mismatch was actually caused by my adding dict(k) to the watch window and it only throws the error when you step through the code and not when you run the code. Even running the code multiple times with a break point on the Next Statement doesn't cause it.?‍♂️

Learn something new every day.

 

[JEC]

I tried that too and also not getting an error, weird…?