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

公式：

$$\rho=1-\dfrac{6\sum\limits_{i=1}^n\Delta{r_i}^2}{n^3-n}$$
其中 $n$是每组数据的个数；$\Delta{r_i}$ 是对应的第 $i$对数据在各自数组中的次序之差；

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

以下代码适用于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 Function

Function 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 Function

Function 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 Function

Function 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 Function

Function 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