如何用VBA实现查找重复项并添加名称？

Question

我想用VBA实现在C36到C47之间查找所有的重复项，并将重复的项目标上名称“2号”“3号”等等，希望最后实现这样的效果，请问怎么写代码，谢谢！

Answer 1

Option Explicit
 
Sub Sfind()
    Dim rng As Range, srng As Range
    Dim dic As Variant, key As Variant
    Dim i As Integer, k As Integer
    With Sheets("Sheet1") '这里选择表格
        Set srng = .[a1:a12] '这里选择要统计重复的区域
        Set dic = CreateObject("Scripting.Dictionary")
        For Each rng In srng
            If Not IsEmpty(rng.Value) Then
                If Not dic.Exists(rng.Value) Then dic.Add rng.Value, 1
            End If
        Next rng
        key = dic.keys
        For i = LBound(key) To UBound(key)
            k = 0
            For Each rng In srng
                If rng.Value = key(i) Then
                k = k + 1
                If k > 1 Then rng.Value = rng.Value & k & "号"
                End If
            Next rng
        Next i
        Set srng = Nothing
        Set dic = Nothing
    End With
End Sub

 防止有什么我没有调试出来的BUG，运行前先备份数据！

Answer 2

Sub test()
Dim i%, d As Object
Set d = CreateObject("scripting.dictionary")
Sheet1.Select
For i = 36 To 47
d(Cells(i, 3).Value) = d(Cells(i, 3).Value) + 1
If d.exists(Cells(i, 3).Value) And d(Cells(i, 3).Value) > 1 Then
Cells(i, 3) = Cells(i, 3) & d(Cells(i, 3).Value) & "号"
End If
Next
set d=nothing
End Sub