Sub 提取重复项()
    Dim d, d1 As Object
    Dim arr
    Dim i As Integer, j As Integer
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Sheet1.Activate
    arr = Range("A1:O59")
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                If Not d.exists(arr(i, j)) Then
                    d.Add arr(i, j), 1
                    d1.Add arr(i, j), "SC" & j
                Else
'                    计算重复值出现次数
                    d.Item(arr(i, j)) = d.Item(arr(i, j)) + 1
'                    存储重复值所在列数
                    d1.Item(arr(i, j)) = d1.Item(arr(i, j)) & "," & "SC" & j
                End If
            End If
        Next
    Next
'    输出并排序
    Sheet2.Activate
    Range("a1").Resize(d.Count) = Application.Transpose(d.keys)
    Range("b1").Resize(d.Count) = Application.Transpose(d.items)
    Range("c1").Resize(d1.Count) = Application.Transpose(d1.items)
    Range("a1:b1:c1").Resize(d.Count).Sort key1:=Range("b2"), Order1:=xlDescending
    Set d = Nothing
    Set d1 = Nothing
    Application.ScreenUpdating = True
End Sub