|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub test()
Dim arr, i, j, d, rng As Range, arr1()
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("E2", [E2].End(xlDown))
For Each i In rng
c = i.Value
d(i.Value) = d(i.Value) + 1
Next
arr0 = d.keys
For i = 0 To d.Count - 1
If d(arr0(i)) > 1 Then
ReDim Preserve arr1(1 To j + 1)
arr1(j + 1) = arr0(i)
j = j + 1
End If
Next
j = 0
rng.RemoveDuplicates 1
rng(1, 2).Resize(UBound(arr1), 1) = Application.WorksheetFunction.Transpose(arr1)
End Sub
|
|