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>