VBA - Find and compare values in multiple columns

Below is a table with a mock up of the data I have and what I need returned in the last column (AJ). What I am trying to do is look though all rows that have the same value in Column M and then compare the values in the rest of the columns noted below. Return same is all the values are the same, return the name(s) of the column(s) if something is different. I have tried starting for each but have two problems 1) its only comparing to previous row, not sets of rows with same value in column M, 2) I can only figure out how to identify on difference, not multiple. Any help is appreciated

'''

Sub CheckSame()

Dim i As Integer
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row


For i = 3 To lastRow
    If Cells(i, 13) = Cells(i - 1, 13) Then
        If Cells(i, 31) = Cells(i - 1, 31) And Cells(i, 32) = Cells(i - 1, 32) And Cells(i, 33) = Cells(i - 1, 33) And Cells(i, 34) = Cells(i - 1, 34) Then
            Cells(i, 36) = "Same"
        ElseIf Cells(i, 32) = Cells(i - 1, 32) And Cells(i, 33) = Cells(i - 1, 33) And Cells(i, 34) = Cells(i - 1, 34) Then
            Cells(i, 36) = "Name"
        ElseIf Cells(i, 31) = Cells(i - 1, 31) And Cells(i, 33) = Cells(i - 1, 33) And Cells(i, 34) = Cells(i - 1, 34) Then
            Cells(i, 36) = "Date"
        ElseIf Cells(i, 31) = Cells(i - 1, 31) And Cells(i, 32) = Cells(i - 1, 32) And Cells(i, 34) = Cells(i - 1, 34) Then
            Cells(i, 36) = "Active"
        ElseIf Cells(i, 31) = Cells(i - 1, 31) And Cells(i, 32) = Cells(i - 1, 32) And Cells(i, 33) = Cells(i - 1, 33) Then
            Cells(i, 36) = "Dept"
        End If
    End If
Next i
End Sub

'''

In principle use 4 dictionaries (1 for each column) to count the number of times a value appears in a group of records.

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

</details>



# 答案2
**得分**: 0

以下是代码部分的翻译：

```vb
    Option Explicit

    Sub FlagUniques()

        ' 定义常量。
        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 = ", "

        ' 引用工作簿。
        Dim wb As Workbook: Set wb = ThisWorkbook ' 包含此代码的工作簿

        ' 引用工作表。
        Dim ws As Worksheet: Set ws = wb.Sheets(WS_NAME)
        Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' 包含标题
        Dim hrg As Range: Set hrg = rg.Rows(1) ' 标题
        Dim rCount As Long: rCount = rg.Rows.Count - 1 ' 没有标题
        Set rg = rg.Resize(rCount).Offset(1) ' 没有标题

        ' 将唯一列的值写入数组（2D 基于一的数组）。
        Dim uData(): uData = rg.Columns(UNIQUE_COL).Value

        ' 将标题从列表中拆分为数组（1D 基于零的数组）。
        Dim Titles() As String: Titles = Split(TITLES_LIST, TITLE_DELiMITER)
        ' 将标题的索引匹配到数组中（1D 基于一的数组）。
        Dim tColIndexes(): tColIndexes = Application.Match(Titles, hrg, 0)

        ' 将标题列的值写入一个交错数组
        ' （1D 基于一的数组，包含基于一的2D 单列数组）。

        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

        ' 将唯一数组中的唯一值写入字典的“键”，
        ' 并将它们的行写入由每个相关“项”持有的集合中。

        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)
            ' 排除错误值和空白。
            If Not IsError(sKey) Then
                If Len(CStr(sKey)) > 0 Then IsFound = True
            End If
            ' 写入。
            If IsFound Then
                If Not dict.Exists(sKey) Then Set dict(sKey) = New Collection
                dict(sKey).Add r
                IsFound = False ' 为下一次迭代重置
            Else
                uData(r, 1) = INVALID_STRING
            End If
        Next r

        ' 循环遍历字典的“键”，遍历交错数组的列，
        ' 并遍历集合中的行，并将所需的结果写入唯一数组。

        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 ' 为下一次迭代重置
            End If
        Next sKey

        ' 将唯一数组中的值写入目标列。
        Dim drg As Range: Set drg = rg.Columns(RESULT_COL)
        drg.Value = uData

        ' 通知。
        MsgBox "唯一值已标记。", vbInformation

    End Sub
```

<details>
<summary>英文:</summary>

Flag Unique Values
-

[![enter image description here][1]][1]

&lt;!-- language: lang-vb --&gt;

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


  [1]: https://i.stack.imgur.com/Nz1h4.jpg

</details>