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

681人阅读 评论(0)

ρ=16i=1nΔri2n3n

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

0
0

* 以上用户言论只代表其个人观点，不代表CSDN网站的观点或立场
个人资料
• 访问：1466302次
• 积分：18685
• 等级：
• 排名：第482名
• 原创：378篇
• 转载：359篇
• 译文：23篇
• 评论：164条
文章分类
阅读排行
最新评论