如何在VBA中为重复数据标记序号并写入BK列？

原代码可检测重复数据并将其复制到tempcek工作表，现扩展功能：按数据出现的先后顺序，为重复数据标记“Duplicate 1”“Duplicate 2”等序号，并将标记写入BK列（示例：Bruce在第2行标记为Duplicate 1，第7行标记为Duplicate 2）。

修改后的完整代码 #

'检测重复数据并标记序号，同时复制到tempcek工作表
Dim objDic As Object, rngData As Range
Dim i As Long, sKey As String, dupRng As Range, rowRng As Range
Dim arrData, oSht1 As Worksheet, oSht2 As Worksheet
Dim countDup As Long
Const KEY_COL = "T" ' 关键列：Email列
Const MARK_COL = "BK" ' 标记写入列
Const COL_CNT = 20 ' 数据范围：A到T列

Set objDic = CreateObject("scripting.dictionary")
Set oSht1 = Sheets("ALL")
Set oSht2 = Sheets("tempcek")

' 清空目标工作表原有标记（可选，按需保留）
oSht1.Range(MARK_COL & ":" & MARK_COL).ClearContents

' 加载源数据
With oSht1
    Set rngData = .Cells(1, KEY_COL).Resize(.Range(KEY_COL & .Rows.Count).End(xlUp).Row)
End With
arrData = rngData.Value

If Not VBA.IsArray(arrData) Then
    MsgBox "Sheet1中无数据。", vbCritical
    Exit Sub
End If

' 遍历数据，标记重复序号并收集重复行
For i = LBound(arrData) + 1 To UBound(arrData)
    arrData(i, 1) = CStr(arrData(i, 1))
    sKey = arrData(i, 1)
    Set rowRng = oSht1.Cells(i, 1)
    
    If objDic.Exists(sKey) Then
        ' 已存在的键，递增计数并标记
        countDup = objDic(sKey) + 1
        objDic(sKey) = countDup
        oSht1.Cells(i, MARK_COL).Value = "Duplicate " & countDup
        
        ' 收集重复行（包括首次出现的行）
        If dupRng Is Nothing Then
            Set dupRng = Application.Union(rowRng, oSht1.Cells(objDic(sKey & "_row"), 1))
        Else
            Set dupRng = Application.Union(dupRng, rowRng, oSht1.Cells(objDic(sKey & "_row"), 1))
        End If
    Else
        ' 首次出现的键，记录计数为1并标记，同时存储行号
        objDic(sKey) = 1
        objDic(sKey & "_row") = i
        oSht1.Cells(i, MARK_COL).Value = "Duplicate 1"
    End If
Next i

' 将重复行复制到tempcek工作表
If Not dupRng Is Nothing Then
    Debug.Print dupRng.Address
    dupRng.EntireRow.Copy oSht2.Range("A2")
End If

关键修改说明 #

• 字典存储优化：新增存储每个键的出现次数和首次出现的行号，实现按顺序标记序号
• 标记逻辑：首次出现的重复项标记为“Duplicate 1”，后续每出现一次序号递增，直接写入BK列
• 保留原有功能：维持原有的重复行收集与复制到tempcek工作表的逻辑，确保功能兼容

内容的提问来源于stack exchange，提问作者little turtle