|
楼主 |
发表于 2015-7-21 11:53
|
显示全部楼层
Sub StatNum()
Dim arr, brr(), crr, drr()
Dim i&, j&, k&, m&, n&, p&
crr = Range("i6:k" & Range("k65536").End(xlUp).Row)
arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
ReDim drr(1 To UBound(crr), 1 To 1)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
On Error Resume Next ’加上这句可行吗?我试了下,找不到元素不会出现下界越标了
For m = 1 To UBound(crr)
For n = 1 To 3
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If arr(i, j) = crr(m, n) Then
k = k + 1
For p = 1 To UBound(brr, 2)
brr(k, p) = arr(i, p)
Next
Exit For
End If
Next j
Next i
arr = brr
ReDim brr(1 To k, 1 To UBound(arr, 2))
k = 0
Next n
drr(m, 1) = UBound(brr)
crr = Range("i6:k" & Range("k65536").End(xlUp).Row)
arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
Next m
Range("L6").Resize(UBound(drr), 1) = drr
End Sub |
|