如何第一列中重复的值提出来？

Qs18

试试.................

Qs18

试试..............

limonet

唉，为什么重开！？

luhming

心的启点 发表于 2024-7-2 16:45
你这个补贴的金额要不要累加起来？

不用，文字连在一起就可以

luhming

Qs18 发表于 2024-7-2 16:51
试试..............

对的，大神就是要这个，谢谢哈

Qs18

Sub qs() '2024/7/2
    Dim arr, dic, i
    With Sheet1
        arr = .Range("a1").CurrentRegion.Value
        Set dic = CreateObject("scripting.dictionary")
        For i = 2 To UBound(arr)
            s = arr(i, 3)
            If Not dic.exists(s) Then
                dic(s) = Array(arr(i, 1), 1)
            Else
                If InStr(dic(s)(0), arr(i, 1)) = 0 Then
                    dic(s) = Array(dic(s)(0) & "、" & arr(i, 1), dic(s)(1) + 1)
                End If
            End If
            
        Next
    For i = 2 To UBound(arr)
        If dic(arr(i, 3))(1) > 1 Then
        arr(i, 5) = dic(arr(i, 3))(0)
        End If
    Next
    .Range("e1").Resize(UBound(arr), 1) = Application.Index(arr, 0, 5)
    End With
End Sub

luhming

limonet 发表于 2024-7-2 16:51
唉，为什么重开！？

怕说不明白，所以又发了一个

Qs18

只显示重复的................

limonet

再见了。再见了。

liulang0808

Sub 按钮1_Click()
    arr = [a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For j = 2 To UBound(arr)
        If Len(arr(j, 3)) > 0 Then
            If d.exists(arr(j, 3)) Then
                d(arr(j, 3)) = d(arr(j, 3)) & "," & arr(j, 1)
            Else
                d(arr(j, 3)) = arr(j, 1)
            End If
        End If
    Next j
    [n1].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
    [o1].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
End Sub