用VBA求条件标准差

hbue_zhx

大家都晓得滴，在EXCEL中用数组函数使起来是灰常灰常灰常滴慢，所以祈求大侠指路，能将附件中的算法用VBA解决，小弟叩头谢过，叩头谢过。。

hbue_zhx

高手，呼唤高手。。。。

zhaogang1960

试试看:
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

zhaogang1960

这是附件:
SOS-条件标准差.rar (17.03 KB, 下载次数: 210)

2011-2-9 16:20 上传

点击文件名下载附件

hbue_zhx

英雄啊，英雄啊，向英雄致敬。。

hbue_zhx

弱弱地问一个：俺要想学会这些东东要从哪里着手呀，

zhaogang1960

原帖由 hbue_zhx 于 2011-2-10 17:05 发表
弱弱地问一个：俺要想学会这些东东要从哪里着手呀，

就从这个论坛上查找基本知识，如：vba板块的本版置顶主题
然后大量实践，在论坛上帮助别人写代码的同时，自己就学会了

DDBB2008

这个厉害了

LMY123

brr(d1(arr(t(i), 1)), d2(arr(t(i), 2))) = .StDev(Cells(t(i), 3).Resize(t(i + 1) - t(i)))