原则上使用4个字典（每列1个）来计算一个值在一组记录中出现的次数。

Option Explicit
Const SHOWPC = True

Sub CompareCols()

   Const COL_ID = "M"
   Const COL_NAME = "AE"
   Const COL_RESULT = "AJ"

   Dim ws As Worksheet, lastrow As Long, i As Long, j As Long
   Dim arDict, arCol, v, n As Long, msg As String
   arCol = Array("Name", "Date", "Active", "Dept")
   
   ReDim arDict(UBound(arCol)) As Object
   For i = 0 To UBound(arDict)
      Set arDict(i) = CreateObject("Scripting.DIctionary")
   Next
   
   Set ws = ThisWorkbook.Sheets("Sheet1")
   With ws
      lastrow = .Cells(.Rows.Count, COL_ID).End(xlUp).Row
      For i = 2 To lastrow
         For j = 0 To 3
            v = .Cells(i, "AE").Offset(, j)
            arDict(j)(v) = arDict(j)(v) + 1 ' count of this value
         Next
         n = n + 1
         
         ' is this last in group
         If .Cells(i + 1, COL_ID) <> .Cells(i, COL_ID) Then
             .Cells(i - n + 1, COL_RESULT).Resize(n, 5) = CompareRows(arDict, arCol)
             n = 0
         End If
      Next
   End With
   
   MsgBox lastrow - 1 & " rows scanned", vbInformation
End Sub

Function CompareRows(ByRef arDict, arCol) As Variant
     
    Dim v, s As String, sep As String, pc As String
    Dim n As Long, i As Long, tot As Long, m As Long
     
    n = UBound(arCol) ' cols to check
    Dim arCount: ReDim arCount(n) As Long
    Dim arResult: ReDim arResult(1 To 1, 1 To n + 2)
     
    ' check each column
    For i = 0 To n
        tot = 0
        For Each v In arDict(i).keys
            m = arDict(i)(v) 'count of value
            tot = tot + m
             ' take v with most entries
            If m > arCount(i) Then
                arCount(i) = m
                arResult(1, i + 2) = v
            End If
        Next
         ' add pcent
        If SHOWPC Then
            pc = Format(arCount(i) / tot, " (0%)")
            arResult(1, i + 2) = arResult(1, i + 2) & pc
        End If
     
        If arDict(i).Count > 1 Then
            s = s & sep & arCol(i)
            sep = ","
        End If
        arDict(i).RemoveAll ' clear dictionary
     Next
     If s = "" Then s = "Same"
     arResult(1, 1) = s
     CompareRows = arResult
     
End Function

标记唯一值

Option Explicit

Sub FlagUniques()
    
    ' Define constants.
    Const WS_NAME As String = "Sheet1"
    Const UNIQUE_COL As String = "M"
    Const RESULT_COL As String = "AJ"
    Const TITLES_LIST As String = "Name,Date,Active,Dept"
    Const TITLE_DELiMITER As String = ","
    Const DUPE_STRING As String = "Same"
    Const UNIQUE_STRING As String = "Unique"
    Const INVALID_STRING As String = "Invalid"
    Const RESULT_DELIMITER As String = ", "
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the range.
    Dim ws As Worksheet: Set ws = wb.Sheets(WS_NAME)
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' has headers
    Dim hrg As Range: Set hrg = rg.Rows(1) ' header
    Dim rCount As Long: rCount = rg.Rows.Count - 1 ' no headers
    Set rg = rg.Resize(rCount).Offset(1) ' no headers
    
    ' Write the values from the unique column to an array (2D one-based).
    Dim uData(): uData = rg.Columns(UNIQUE_COL).Value
    
    ' Split the titles from the list into an array (1D zero-based).
    Dim Titles() As String: Titles = Split(TITLES_LIST, TITLE_DELiMITER)
    ' Match the title indexes into an array (1D one-based).
    Dim tColIndexes(): tColIndexes = Application.Match(Titles, hrg, 0)
    
    ' Write the values from the title columns to a jagged array
    ' (1D one-based, containing 2D one-based single-column arrays).
    
    Dim tCount As Long: tCount = UBound(tColIndexes)
    Dim tJag(): ReDim tJag(1 To tCount)
    
    Dim t As Long
    
    For t = 1 To tCount
        tJag(t) = rg.Columns(tColIndexes(t)).Value
    Next t
    
    ' Write the unique values from the unique array to the 'keys'
    ' of a dictionary, and their rows to a collection held
    ' by each associated 'item'.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim sKey, r As Long, IsFound As Boolean
    
    For r = 1 To rCount
        sKey = uData(r, 1)
        ' Exclude error values and blanks.
        If Not IsError(sKey) Then
            If Len(CStr(sKey)) > 0 Then IsFound = True
        End If
        ' Write.
        If IsFound Then
            If Not dict.Exists(sKey) Then Set dict(sKey) = New Collection
            dict(sKey).Add r
            IsFound = False ' reset for the next iteration
        Else
            uData(r, 1) = INVALID_STRING
        End If
    Next r
            
    ' Loop through the 'keys' of the dictionary, through the columns
    ' of the jagged array, and through the rows in the collections
    ' and write the required results to the unique array.
    
    Dim rLen As Long: rLen = Len(RESULT_DELIMITER)
            
    Dim Item, tVal, fr As Long, c As Long, cCount As Long, Result As String
            
    For Each sKey In dict.Keys
        cCount = dict(sKey).Count
        fr = dict(sKey)(1)
        If cCount = 1 Then
            uData(fr, 1) = UNIQUE_STRING
        Else
            For t = 1 To tCount
                tVal = tJag(t)(fr, 1)
                For c = 2 To cCount
                    r = dict(sKey)(c)
                    If tJag(t)(r, 1) <> tVal Then Exit For
                Next c
                If c <= cCount Then
                    Result = Result & Titles(t - 1) & RESULT_DELIMITER
                End If
                Debug.Print t, tVal, c, Result
            Next t
            If Len(Result) = 0 Then
                Result = DUPE_STRING
            Else
                Result = Left(Result, Len(Result) - rLen)
            End If
            For c = 1 To cCount
                uData(dict(sKey)(c), 1) = Result
            Next c
            Result = vbNullString ' reset for the next iteration
        End If
    Next sKey
            
    ' Write the values from the unique array to the destination column.
    Dim drg As Range: Set drg = rg.Columns(RESULT_COL)
    drg.Value = uData

    ' Inform.
    MsgBox "Unique values flagged.", vbInformation

End Sub