Find the number of duplicates (Column for particular record with each serial number)

Question

I need the expert help in VBA Excel code. I need to find the number of duplicate record (AlertToString) for particular device serial number from the source sheet serial number and paste it to the other newly created output sheet by using VBA Macro.

Example (Source sheet):

Expected (Output Sheet with repeat Alert count) :

Source code as below :

 Sub Alert700Count()
 
Dim AlertSource_Sh As Worksheet
Dim AlertOutput_Sh As Worksheet

'Insert a New Blank Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("AlertOutput").Delete
 
Sheets.Add.Name = "AlertOutput"
Application.DisplayAlerts = True

Set AlertSource_Sh = ThisWorkbook.Sheets("SourceSheet")
Set AlertOutput_Sh = ThisWorkbook.Sheets("AlertOutput")
    
AlertOutput_Sh.Cells(1, 1) = "Serial No"
AlertOutput_Sh.Cells(1, 2) = "A92"
AlertOutput_Sh.Cells(1, 3) = "A95"
AlertOutput_Sh.Cells(1, 4) = "A98"
 

 For Each sh In ActiveWorkbook.Worksheets
        With sh.Range("A1:D1")
            .Font.Bold = True
            .WrapText = True
            .CellWidth = 35
            .Selection.Font.ColorIndex = 49
            .Weight = xlMedium
            .LineStyle = xlDash
        End With
    Next sh
    
AlertOutput_Sh.Range("A1:D1").Borders.Color = RGB(10, 201, 88)
AlertOutput_Sh.Columns("A:D").ColumnWidth = 12
AlertOutput_Sh.Range("A1:D1").Font.Color = rgbBlueViolet
AlertOutput_Sh.Range("A1:D1").Interior.Color = vbYellow
AlertOutput_Sh.Range("A1:D1").HorizontalAlignment = xlCenter
AlertOutput_Sh.Range("A1:D1").VerticalAlignment = xlTop
    
' Search the duplicate record and paste in output sheet
Dim A92Count As Long
A92Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A92")
AlertOutput_Sh.Cells(2, 2) = A92Count

Dim A95Count As Long
A95Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A95")
AlertOutput_Sh.Cells(2, 3) = A92Count

Dim A98Count As Long
A98Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A98")
AlertOutput_Sh.Cells(2, 4) = A98Count

End Sub

Current Output :

Answer 1

Use Dictionaries to build lists of unique values and an array to hold the counts.

Option Explicit

Sub Alert700Count()

    Dim wsData As Worksheet, wsOut As Worksheet
    Dim dictSerNo As Object, dictAlert As Object
    
    Dim arData, arOut, k, rngOut As Range
    Dim lastrow As Long, i As Long
    Dim serNo As String, alert As String
    Dim r As Long, c As Long, t0 As Single: t0 = Timer
    
    Set dictSerNo = CreateObject("Scripting.Dictionary")
    Set dictAlert = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("AlertOutput").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Sheets.Add.Name = "AlertOutput"
    Set wsOut = Sheets("AlertOutput")
    Set wsData = Sheets("SourceSheet")
    
    r = 1: c = 1
    With wsData
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        arData = .Range("A1:D" & lastrow).Value2
       
        ' get unique serno and alert
        For i = 2 To lastrow
            serNo = arData(i, 1)
            alert = arData(i, 4)
           
            If dictSerNo.exists(serNo) Then
            ElseIf Len(serNo) > 0 Then
                r = r + 1
                dictSerNo.Add serNo, r
            End If
           
            If dictAlert.exists(alert) Then
            ElseIf Len(alert) > 0 Then
                c = c + 1
                dictAlert.Add alert, c
            End If
        Next
        
       ' rescan for counts
        ReDim arOut(1 To r, 1 To c)
        For i = 2 To lastrow
            r = dictSerNo(CStr(arData(i, 1)))
            c = dictAlert(CStr(arData(i, 4)))
            arOut(r, c) = arOut(r, c) + 1
        Next
    End With
    
    ' add headers
    arOut(1, 1) = "Serial No"
    ' sernos and alerts
    For Each k In dictSerNo
        arOut(dictSerNo(k), 1) = k
    Next
    For Each k In dictAlert
        arOut(1, dictAlert(k)) = k
    Next
   
    ' output counts
    With wsOut
         Set rngOut = .Range("A1").Resize(UBound(arOut), UBound(arOut, 2))
         rngOut.Value2 = arOut
         rngOut.Replace "", 0
         .ListObjects.Add(xlSrcRange, rngOut, , xlYes).Name = "Table1"
         .Range("A1").AutoFilter
         .Range("A1").Select
    End With
    
    MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub