|
写 的 有 点 乱
Sub 水一个()
Dim arr, d, ar()
Dim x%, y%, z%, n%
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
For x = 2 To UBound(arr)
d(arr(x, 5)) = d(arr(x, 5)) + 1
Next
k = d.keys
it = d.items
For y = 0 To d.Count - 1
For x = 2 To UBound(arr)
ReDim Preserve ar(1 To it(0), 1 To 6)
If arr(x, 5) = k(y) Then
n = n + 1
For z = 1 To 6
ar(n, z) = arr(x, z)
Next
End If
Next
Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
sh.Name = k(y)
Sheets("报表").Range("a1:f1").Copy sh.Range("a1")
sh.Range("a2").Resize(it(0), 6) = ar
n = 0
Erase ar
Next
End Sub |
评分
-
1
查看全部评分
-
|