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).

 

[Alex Blakenburg]

Thanks for looking at it. I should probably leave it there since it is not really relevant to the OPs thread.

 

[Tupe77]

Does this code implement the functionality you want?
This need Workbook sheets "Input" & "Output"

Sub TS_maxconrep() ' for mrexcel.com forum https://www.mrexcel.com/board/threads/how-to-find-the-maximum-consecutive-repeated-value-on-the-bases-of-two-column-in-vba-excel.1191857/
Dim TmpArr As Variant, Key As Variant, Arr() As Variant, StrArr As Variant
Dim TmpRng As Range, ReturnRNG As Range
Dim rw As Long, TmpStr As String, i As Long
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

With Sheets("Input")
'***** Creating source Range *********************************************************
    rw = .Range("A65536").End(xlUp).Row
    Set TmpRng = .Range("A2" & ":" & "B" & rw)
'***** Creating array ****************************************************************
    TmpArr = TmpRng.Value

'***** ARRAY VALUES TO DICTIONARY ****************************************************
        For i = LBound(TmpArr) To UBound(TmpArr)
            TmpStr = CStr(TmpArr(i, 1) & ":" & TmpArr(i, 2))
            If dict.Exists(TmpStr) Then
                dict(TmpStr) = dict(TmpStr) + 1
            Else
                If Len(TmpStr) > 0 Then dict.Add (TmpStr), 1
           End If
        Next i

End With

'***** FIT ARRAY SIZE TO DICTIONARY **************************************************
ReDim Arr(1 To dict.Count, 1 To 3)
i = 1

'***** DICTIONARY VALUES TO ARRAY ****************************************************
For Each Key In dict.Keys '
    StrArr = split(Key, ":")
        Arr(i, 1) = StrArr(0)
        Arr(i, 2) = StrArr(1)
        Arr(i, 3) = dict(Key)
        i = i + 1
 Next Key
 
 Sheets("Output").Range("A2").Resize(UBound(Arr, 1), 3).Value = Arr
End Sub