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

Mine source code as below but this does not reference the 1st Column Serial Number (This only work for One column like AlertCode) :

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)

CodePudding user response：

Screenshot(s) /

The summary table itself shall comprise a number of rows (depending upon range_data) and 3 columns (given the input/Q) - this will be produced by the macro (code below) and can be seen in screenshot above (G3:I5) - the macro functions shall determine the appropriate dimensions automatically

Code

With these two named ranges (i.e. 'range_data' & 'range_summary_startcell') defined, the following VB code produces the desired output per your Q:

Sub Macro_Summary()
'
'JB_007 07/01/2022
'

'
    Application.ScreenUpdating = True
    Range("range_summary_startcell").Select
    ActiveCell.Formula2R1C1 = "=UNIQUE(range_data)"
    ActiveSheet.Calculate
    x = ActiveCell.End(xlDown).Row

    
    Set range_count = ActiveCell.Offset(0, 2)
    range_count.Select
    range_count.Formula2R1C1 = _
        "=COUNTIFS(INDEX(range_data,0,2),RC[-1],INDEX(range_data,0,1),RC[-2])"

    
    Selection.AutoFill Destination:=Range(range_count, range_count.Offset(x - range_count.Row))
    ActiveSheet.Calculate
End Sub

Caveats: assumes you have Office 365 compatible version of Excel

GIF - Running Macro

Notes (♪) saved as macro-free workbook for your own security if you wish to download underlying workbook - otherwise identical to screenshot(s) in this proposed soln.

CodePudding user response：

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