计算Spearman等级相关系数的VBA函数

公式：

ρ=1−6∑i=1nΔri2n3−n

其中n是每组数据的个数；Δri 是对应的第i对数据在各自数组中的次序之差；

因为次序r的定义有不同可能，所以，得到的ρ可能有差异。

以下代码适用于Excel不同版本（老版本只提供了rank，不能取平均，2007以后功能得到了加强，有多选择）,

Function Spearman(Rng1 As Range, Rng2 As Range) As Double    Dim WF As WorksheetFunction    Dim dSquared() As Long    Dim r As Long    Set WF = WorksheetFunction    ReDim Preserve dSquared(1 To Rng1.Cells.Count)    If Rng1.Columns.Count < 2 Then      For r = LBound(dSquared) To UBound(dSquared)         dSquared(r) = (WF.Rank(Rng1.Cells(r, 1), Rng1) - WF.Rank(Rng2.Cells(r, 1), Rng2)) ^ 2      Next r    Else      For r = LBound(dSquared) To UBound(dSquared)         dSquared(r) = (WF.Rank(Rng1.Cells(1, r), Rng1) - WF.Rank(Rng2.Cells(1, r), Rng2)) ^ 2      Next r    End If    Spearman = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Cells.Count ^ 3) - Rng1.Cells.Count))End FunctionFunction SpearmanAvg(Rng1 As Range, Rng2 As Range) As Double    Dim WF As WorksheetFunction    Dim dSquared() As Double    Dim r As Long    Set WF = WorksheetFunction    ReDim Preserve dSquared(1 To Rng1.Cells.Count)    If Rng1.Columns.Count < 2 Then        For r = LBound(dSquared) To UBound(dSquared)            dSquared(r) = (WF.Rank_Avg(Rng1.Cells(r, 1), Rng1) - WF.Rank_Avg(Rng2.Cells(r, 1), Rng2)) ^ 2        Next r    Else        For r = LBound(dSquared) To UBound(dSquared)            dSquared(r) = (WF.Rank_Avg(Rng1.Cells(1, r), Rng1) - WF.Rank_Avg(Rng2.Cells(1, r), Rng2)) ^ 2        Next r    End If    SpearmanAvg = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Cells.Count ^ 3) - Rng1.Cells.Count))End FunctionFunction SpearmanEq(Rng1 As Range, Rng2 As Range) As Double    Dim WF As WorksheetFunction    Dim dSquared() As Long    Dim r As Long    Set WF = WorksheetFunction    ReDim Preserve dSquared(1 To Rng1.Cells.Count)    If Rng1.Columns.Count < 2 Then      For r = LBound(dSquared) To UBound(dSquared)         dSquared(r) = (WF.Rank_Eq(Rng1.Cells(r, 1), Rng1) - WF.Rank_Eq(Rng2.Cells(r, 1), Rng2)) ^ 2      Next r    Else      For r = LBound(dSquared) To UBound(dSquared)         dSquared(r) = (WF.Rank_Eq(Rng1.Cells(1, r), Rng1) - WF.Rank_Eq(Rng2.Cells(1, r), Rng2)) ^ 2      Next r    End If    SpearmanEq = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Cells.Count ^ 3) - Rng1.Cells.Count))End Function

以下为原始代码

Function Spearman(Rng1 As Range, Rng2 As Range) As Double    Dim WF As WorksheetFunction    Dim dSquared() As Long    Dim r As Long    Set WF = WorksheetFunction    ReDim Preserve dSquared(1 To Rng1.Rows.Count)    For r = LBound(dSquared) To UBound(dSquared)       dSquared(r) = (WF.Rank(Rng1.Cells(r, 1), Rng1) - WF.Rank(Rng2.Cells(r, 1), Rng2)) ^ 2    Next r    Spearman = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Rows.Count ^ 3) - Rng1.Rows.Count))End FunctionFunction SpearmanAvg(Rng1 As Range, Rng2 As Range) As Double    Dim WF As WorksheetFunction    Dim dSquared() As Long    Dim r As Long    Set WF = WorksheetFunction    ReDim Preserve dSquared(1 To Rng1.Rows.Count)    For r = LBound(dSquared) To UBound(dSquared)       dSquared(r) = (WF.Rank_Avg(Rng1.Cells(r, 1), Rng1) - WF.Rank_Avg(Rng2.Cells(r, 1), Rng2)) ^ 2    Next r    SpearmanAvg = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Rows.Count ^ 3) - Rng1.Rows.Count))End FunctionFunction SpearmanEq(Rng1 As Range, Rng2 As Range) As Double    Dim WF As WorksheetFunction    Dim dSquared() As Long    Dim r As Long    Set WF = WorksheetFunction    ReDim Preserve dSquared(1 To Rng1.Rows.Count)    For r = LBound(dSquared) To UBound(dSquared)       dSquared(r) = (WF.Rank_Eq(Rng1.Cells(r, 1), Rng1) - WF.Rank_Eq(Rng2.Cells(r, 1), Rng2)) ^ 2    Next r    SpearmanEq = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Rows.Count ^ 3) - Rng1.Rows.Count))End Function