怎么单列查重并修改底色和插入批注？

zhuxucheng

ykcbf1100

做了一个表，另一个表你自己照着写一下吧。

ykcbf1100

1. Sub ykcbf()   '//2025.3.31
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("原始表").UsedRange
   
5.     With Sheets("要生成的第1个表")
   
6.         .Cells.Clear
   
7.         .[b1].Resize(UBound(arr), UBound(arr, 2)) = arr
   
8.         arr = .[a1].Resize(UBound(arr), UBound(arr, 2) + 1)
   
9.         For i = 2 To UBound(arr)
   
10.             s = arr(i, 3)
    
11.             If s <> Empty Then d(s) = d(s) & " " & i
    
12.         Next
    
13.         For Each k In d.keys
    
14.             t = Split(Mid(d(k), 2))
    
15.             u = UBound(t)
    
16.             If u > 0 Then
    
17.                 m = m + 1
    
18.                 For x = 0 To u
    
19.                     .Cells(Val(t(x)), 3).Interior.ColorIndex = m + 3
    
20.                     .Cells(Val(t(x)), 1) = u + 1
    
21.                 Next
    
22.                 Set Rng = .Cells(Val(t(0)), 3)
    
23.                 Rng.AddComment
    
24.                 Rng.Comment.Text Text:="共出现" & CStr(u + 1) & "次"
    
25.             End If
    
26.         Next
    
27.     End With
    
28.     Set d = Nothing
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    
32. 
    

复制代码

liulang0808

Sub test()
    Set sh = Sheets("原始表")
    Set d = CreateObject("scripting.dictionary")
    arr = sh.UsedRange
    For j = 2 To UBound(arr)
        d(arr(j, 2)) = d(arr(j, 2)) & "," & j
    Next j
    Application.ScreenUpdating = False
    sh.Copy after:=Sheets(1)
    Sheets(2).Name = "结果1"
    Sheets(2).Columns(1).Insert
    sh.Copy after:=Sheets(1)
    Sheets(2).Name = "结果2"
    Sheets(2).Columns(1).Insert
    x = 2
    y = 0
    Set Rng = Nothing
    For Each k In d.keys
        brr = Split(d(k), ",")
        If UBound(brr) >= 2 Then
            y = y + 1
            x = x + 1
            If x >= 56 Then x = 3
            Sheets("结果1").Cells(Val(brr(1)), 3).AddComment "共重复次数为：" & UBound(brr)
            Sheets("结果2").Cells(Val(brr(1)), 3).AddComment "共重复次数为：" & UBound(brr)
            For j = 1 To UBound(brr)
                Sheets("结果1").Cells(Val(brr(j)), 1) = y
                Sheets("结果1").Cells(Val(brr(j)), 3).Interior.ColorIndex = x
                Sheets("结果2").Cells(Val(brr(j)), 1) = y
                Sheets("结果2").Cells(Val(brr(j)), 3).Interior.ColorIndex = x
                If j > 1 Then
                    If Rng Is Nothing Then
                        Set Rng = Sheets("结果2").Cells(Val(brr(j)), 1)
                    Else
                        Set Rng = Union(Rng, Sheets("结果2").Cells(Val(brr(j)), 1))
                    End If
                End If
            Next j
        End If
    Next k
    If Not Rng Is Nothing Then Rng.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。
颜色楼主可以根据自己的需求设置