|
看看结果对不
Sub test()
Dim i, n, j, arr, k, l, m
Dim dic
Set dic = CreateObject("scripting.dictionary")
n = Sheet3.Cells(Rows.Count, 1).End(3).Row
arr = Sheet3.Range("a1:c" & n)
For j = 1 To 3
For i = 2 To n
If Not dic.exists(arr(i, j)) Then
dic(arr(i, j)) = 1
Else
dic(arr(i, j)) = dic(arr(i, j)) + 1
End If
Next
Next
keys = dic.keys
its = dic.items
ReDim brr(1 To UBound(arr), 1 To 1)
ReDim crr(1 To UBound(arr), 1 To 1)
ReDim drr(1 To UBound(arr), 1 To 1)
For i = 0 To dic.Count - 1
If its(i) = 3 Then
k = k + 1
brr(k, 1) = keys(i)
ElseIf its(i) = 2 Then
l = lk + 1
crr(l, 1) = keys(i)
ElseIf its(i) = 1 Then
m = m + 1
drr(m, 1) = keys(i)
End If
Next
With Sheet3
.Range("d2:f2").Resize(UBound(arr)).ClearContents
.Range("d2").Resize(UBound(brr)) = brr
.Range("e2").Resize(UBound(crr)) = crr
.Range("f2").Resize(UBound(drr)) = drr
End With
End Sub |
评分
-
1
查看全部评分
-
|