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

本文主要是介绍计算Spearman等级相关系数的VBA函数，希望对大家解决编程问题提供一定的参考价值，需要的开发者们随着小编来一起学习吧！

公式：

ρ = 1 - 6 \sum i = 1 n Δ r i 2 n 3 - n

$\rho=1-\dfrac{6\sum\limits_{i=1}^n\Delta{r_i}^2}{n^3-n}$
其中

n $n$ 是每组数据的个数；

Δri $\Delta{r_i}$ 是对应的第

i $i$ 对数据在各自数组中的次序之差；

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

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

Function Spearman(Rng1 As Range, Rng2 As Range) As DoubleDim WF As WorksheetFunctionDim dSquared() As LongDim r As LongSet WF = WorksheetFunctionReDim Preserve dSquared(1 To Rng1.Cells.Count)If Rng1.Columns.Count < 2 ThenFor r = LBound(dSquared) To UBound(dSquared)dSquared(r) = (WF.Rank(Rng1.Cells(r, 1), Rng1) - WF.Rank(Rng2.Cells(r, 1), Rng2)) ^ 2Next rElseFor r = LBound(dSquared) To UBound(dSquared)dSquared(r) = (WF.Rank(Rng1.Cells(1, r), Rng1) - WF.Rank(Rng2.Cells(1, r), Rng2)) ^ 2Next rEnd IfSpearman = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Cells.Count ^ 3) - Rng1.Cells.Count))
End FunctionFunction SpearmanAvg(Rng1 As Range, Rng2 As Range) As DoubleDim WF As WorksheetFunctionDim dSquared() As DoubleDim r As LongSet WF = WorksheetFunctionReDim Preserve dSquared(1 To Rng1.Cells.Count)If Rng1.Columns.Count < 2 ThenFor r = LBound(dSquared) To UBound(dSquared)dSquared(r) = (WF.Rank_Avg(Rng1.Cells(r, 1), Rng1) - WF.Rank_Avg(Rng2.Cells(r, 1), Rng2)) ^ 2Next rElseFor r = LBound(dSquared) To UBound(dSquared)dSquared(r) = (WF.Rank_Avg(Rng1.Cells(1, r), Rng1) - WF.Rank_Avg(Rng2.Cells(1, r), Rng2)) ^ 2Next rEnd IfSpearmanAvg = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Cells.Count ^ 3) - Rng1.Cells.Count))
End FunctionFunction SpearmanEq(Rng1 As Range, Rng2 As Range) As DoubleDim WF As WorksheetFunctionDim dSquared() As LongDim r As LongSet WF = WorksheetFunctionReDim Preserve dSquared(1 To Rng1.Cells.Count)If Rng1.Columns.Count < 2 ThenFor r = LBound(dSquared) To UBound(dSquared)dSquared(r) = (WF.Rank_Eq(Rng1.Cells(r, 1), Rng1) - WF.Rank_Eq(Rng2.Cells(r, 1), Rng2)) ^ 2Next rElseFor r = LBound(dSquared) To UBound(dSquared)dSquared(r) = (WF.Rank_Eq(Rng1.Cells(1, r), Rng1) - WF.Rank_Eq(Rng2.Cells(1, r), Rng2)) ^ 2Next rEnd IfSpearmanEq = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Cells.Count ^ 3) - Rng1.Cells.Count))End Function

以下为原始代码

Function Spearman(Rng1 As Range, Rng2 As Range) As DoubleDim WF As WorksheetFunctionDim dSquared() As LongDim r As LongSet WF = WorksheetFunctionReDim 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)) ^ 2Next rSpearman = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Rows.Count ^ 3) - Rng1.Rows.Count))
End FunctionFunction SpearmanAvg(Rng1 As Range, Rng2 As Range) As DoubleDim WF As WorksheetFunctionDim dSquared() As LongDim r As LongSet WF = WorksheetFunctionReDim 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)) ^ 2Next rSpearmanAvg = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Rows.Count ^ 3) - Rng1.Rows.Count))
End FunctionFunction SpearmanEq(Rng1 As Range, Rng2 As Range) As DoubleDim WF As WorksheetFunctionDim dSquared() As LongDim r As LongSet WF = WorksheetFunctionReDim 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)) ^ 2Next rSpearmanEq = 1 - ((6 * WF.Sum(dSquared)) / ((Rng1.Rows.Count ^ 3) - Rng1.Rows.Count))
End Function