|
|
试试看:
Sub Macro1()
Dim d As Object, d1 As Object, d2 As Object, arr, brr(), t, i&, m&, n&
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
arr1 = .Value
.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlGuess
arr = .Value
End With
For i = 2 To UBound(arr)
s = arr(i, 1) & Chr(9) & arr(i, 2)
If Not d.Exists(s) Then d(s) = i
Next
d("") = i
t = d.items
ReDim brr(1 To UBound(arr), 1 To UBound(arr))
Range("G2").CurrentRegion.ClearContents
With WorksheetFunction
For i = 0 To d.Count - 2
If Not d1.Exists(arr(t(i), 1)) Then
m = m + 1
d1(arr(t(i), 1)) = m
End If
If Not d2.Exists(arr(t(i), 2)) Then
n = n + 1
d2(arr(t(i), 2)) = n
End If
brr(d1(arr(t(i), 1)), d2(arr(t(i), 2))) = .StDev(Cells(t(i), 3).Resize(t(i + 1) - t(i)))
Next
Range("G3").Resize(m) = .Transpose(d1.keys)
End With
Range("h2").Resize(, n) = d2.keys
Range("h3").Resize(m, n) = brr
Range("A1").CurrentRegion.Value = arr1
Application.ScreenUpdating = True
End Sub |
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-2-9 15:40
楼主
