处理区域重复的保留一个，结果在原区域写入

1635967374

处理区域Range("A2:L15")重复的保留一个，重复的多少次写成批注，得处的结果在原区域Range("A2:L15")写入

1635967374

第一列后面的行有公式是空值，怎么定位公式计算有结果的值，[a1].end(xldown)是行不通的，只能定位到最后一行带有公式的空值

1635967374

高手们帮忙啊

网海遨游

没能很好理解楼主意思，猜一个。


Sub test()
        Dim d, rng
        Set d = CreateObject("Scripting.Dictionary") '定义字典对象
        For Each rng In Range("A2:L15")
                If rng <> "" Then d(rng.Value) = d(rng.Value) + 1
        Next rng
        Cells.ClearContents
        Cells.ClearComments
        Ik = d.keys: Im = d.items
        [a1].Resize(, d.Count) = Ik
        For i = 1 To d.Count
                With Cells(1, i)
                        .AddComment
                         .Comment.Visible = False
                         .Comment.Text "" & Im(i - 1) & ""
                End With
        Next i
End Sub

xuemei0216

Sub a()
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Dim rng As Range
For Each rng In ActiveSheet.[a2:l15]           '数据源，按行提取
    If rng <> "" And Not d.exists(rng.Value) Then
        d(rng.Value) = 1
    Else
        d(rng.Value) = d(rng.Value) + 1
        rng.Value = ""
    End If
Next
For Each rng In ActiveSheet.[a2:l15]
    If rng <> "" Then
        rng.ClearComments       '清除批注
        rng.AddComment          '增加,批注
        rng.Comment.Text "重复次数:" & d(rng.Value)        '增加,批注内容
    End If
Next
Set d = Nothing
End Sub

1635967374

xuemei0216 发表于 2019-9-29 16:53
Sub a()
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")

字典数组转置写入[a2:l15],这种方法好象不好弄对吧？也就是从新一个数挨着一个数(不用再加其它循环代码的方法)。

xuemei0216

1635967374 发表于 2019-9-29 18:22
字典数组转置写入[a2:l15],这种方法好象不好弄对吧？也就是从新一个数挨着一个数(不用再加其它循环代码的 ...

Sub a()
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Dim rng As Range
For Each rng In ActiveSheet.[a2:l15]           '数据源，按行提取
    If rng <> "" Then d(rng.Value) = d(rng.Value) + 1
Next
Dim i&, j&, k&
[a2:l15].ClearContents
[a2:l15].ClearComments       '清除批注
For i = 2 To 15
    For j = 1 To 7
        If k <= d.Count - 1 Then
            Cells(i, j) = d.keys()(k)
            Cells(i, j).AddComment          '增加,批注
            Cells(i, j).Comment.Text "重复次数:" & d(Cells(i, j).Value)        '增加,批注内容
            k = k + 1
        End If
    Next
Next
Set d = Nothing
End Sub