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

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>