Kappa係数

Excelファイルの画面

マクロの使用方法について

ファイルを開く際マクロを有効にして下さい（ウィルス・マクロでは決してありません）．
ワークシートMatrix1にerror matrixをコピー．
ワークシートMatrix2にerror matrixをコピー．
ワークシートResultにある矢印を押す．
以上で終了です．

Excelファイルをダウンロード

ご使用にあたって

本ファイルについて使用者自身によるVBA script，画面レイアウトの変更については特に制限を加えませんが，それを無断で配布することは禁じます。
使用者による本ファイルのいかなる使用についても，その責任は使用者自身が負うもので，作者は責任を負うものではありません。作者は，その内容についても，明示であると黙示であるとを問わず，一切保証をするものではありません。本ファイルの使用もしくは機能から生じる全ての損害は，使用者自身が負担しなければなりません。
作者は、本ファイルの使用または使用不能から生じる一切の損害（逸失利益，事業の中断，事業情報の喪失またはその他の金銭的損失など）に関して一切責任を負いません。

VBA script

Sub Kappa1()
Dim Rc As Integer
Dim C As Integer
Dim R As Integer
Dim Xii As Double
Dim Xip As Double
Dim Xpi As Double
Dim Xij As Double
Dim Xjp As Double
Dim T As Double
Dim K As Double
Dim S1 As Double
Dim S2 As Double
Dim S3 As Double
Dim S4 As Double
Dim SS1 As Double
Dim SS2 As Double
Dim SS3 As Double
Dim SS4 As Double
Dim P1 As Single
Dim P2 As Single
Dim P3 As Single
Dim Sig As Single
Dim WS1
Dim WS2
Dim WS3
Set WS1 = Sheets("Matrix1")
Set WS2 = Sheets("Matrix1_")
Set WS3 = Sheets("Result") With WS1.Cells(1, 1).CurrentRegion
Rc = .Rows.Count
End With
WS2.Select
ActiveSheet.Cells.Select
Selection.ClearContents
WS1.Select
Range(Cells(1, 1), Cells(Rc, Rc)).Select
Selection.Copy
WS2.Select
ActiveSheet.Paste Destination:=Range(Cells(1, 1), Cells(Rc, Rc))
Range(Cells(1, 1), Cells(Rc, Rc)).Select
Selection.Font.ColorIndex = 5
'Marginal Sum
For C = 1 To Rc
WS2.Select
Xip = Application.Sum(Range(Cells(1, C), Cells(Rc, C)))
Cells(Rc + 1, C).Value = Xip
Next C
For R = 1 To Rc
WS2.Select
Xpi = Application.Sum(Range(Cells(R, 1), Cells(R, Rc)))
Cells(R, Rc + 1).Value = Xpi
Next R
'Total
T = 0
WS2.Select
T = Application.Sum(Range(Cells(Rc + 1, 1), Cells(Rc + 1, Rc)))
Cells(Rc + 1, Rc + 1).Value = T
Cells(Rc + 1, Rc + 1).Select
Selection.Font.ColorIndex = 10
'Kappa, S1, S2, S3
Xii = 0
Xip = 0
Xpi = 0
K = 0
S1 = 0
S2 = 0
S3 = 0
S4 = 0
SS1 = 0
SS2 = 0
SS3 = 0
SS4 = 0
For C = 1 To Rc
WS2.Select
Xii = Cells(C, C)
Xip = Cells(Rc + 1, C)
Xpi = Cells(C, Rc + 1)
SS1 = SS1 + Xii
SS2 = SS2 + (Xip * Xpi)
SS3 = SS3 + Xii * (Xip + Xpi)
Next C
K = (T * SS1 - SS2) / (T ^ 2 - SS2)
S1 = SS1 / T
S2 = SS2 / T ^ 2
S3 = SS3 / T ^ 2
'S4
Xij = 0
Xjp = 0
Xpi = 0
For C = 1 To Rc
For R = 1 To Rc
Xij = Cells(C, R)
Xjp = Cells(Rc + 1, R)
Xpi = Cells(C, Rc + 1)
SS4 = SS4 + Xij * (Xjp + Xpi) ^ 2
Next R
Next C
S4 = SS4 / T ^ 3
'Sigma
P1 = 0
P2 = 0
P3 = 0
P1 = (S1 * (1 - S1)) / (1 - S2) ^ 2
P2 = 2 * (1 - S1) * (2 * S1 * S2 - S3) / (1 - S2) ^ 3
P3 = (1 - S1) ^ 2 * (S4 - 4 * S2 ^ 2) / (1 - S2) ^ 4
Sig = Sqr((1 / T) * (P1 + P2 + P3))
'Display
WS2.Cells(Rc + 4, 1).Value = "Kappa"
WS2.Cells(Rc + 6, 1).Value = "S1"
WS2.Cells(Rc + 7, 1).Value = "S2"
WS2.Cells(Rc + 8, 1).Value = "S3"
WS2.Cells(Rc + 9, 1).Value = "S4"
WS2.Cells(Rc + 11, 1).Value = "Sigma"
WS2.Cells(Rc + 4, 2).Value = K
WS2.Cells(Rc + 6, 2).Value = S1
WS2.Cells(Rc + 7, 2).Value = S2
WS2.Cells(Rc + 8, 2).Value = S3
WS2.Cells(Rc + 9, 2).Value = S4
WS2.Cells(Rc + 11, 2).Value = Sig
WS3.Select
WS3.Cells(3, 3).Value = K
WS3.Cells(5, 3).Value = Sig
End Sub
Sub Kappa2()
Dim Rc As Integer
Dim C As Integer
Dim R As Integer
Dim Xii As Double
Dim Xip As Double
Dim Xpi As Double
Dim Xij As Double
Dim Xjp As Double
Dim T As Double
Dim K As Double
Dim S1 As Double
Dim S2 As Double
Dim S3 As Double
Dim S4 As Double
Dim SS1 As Double
Dim SS2 As Double
Dim SS3 As Double
Dim SS4 As Double
Dim P1 As Single
Dim P2 As Single
Dim P3 As Single
Dim Sig As Single
Dim WS1
Dim WS2
Dim WS3
Set WS1 = Sheets("Matrix2")
Set WS2 = Sheets("Matrix2_")
Set WS3 = Sheets("Result")
With WS1.Cells(1, 1).CurrentRegion
Rc = .Rows.Count
End With
WS2.Select
ActiveSheet.Cells.Select
Selection.ClearContents
WS1.Select
Range(Cells(1, 1), Cells(Rc, Rc)).Select
Selection.Copy
WS2.Select
ActiveSheet.Paste Destination:=Range(Cells(1, 1), Cells(Rc, Rc))
Range(Cells(1, 1), Cells(Rc, Rc)).Select
Selection.Font.ColorIndex = 5
'Marginal Sum
For C = 1 To Rc
WS2.Select
Xip = Application.Sum(Range(Cells(1, C), Cells(Rc, C)))
Cells(Rc + 1, C).Value = Xip
Next C
For R = 1 To Rc
WS2.Select
Xpi = Application.Sum(Range(Cells(R, 1), Cells(R, Rc)))
Cells(R, Rc + 1).Value = Xpi
Next R
'Total
T = 0
WS2.Select
T = Application.Sum(Range(Cells(Rc + 1, 1), Cells(Rc + 1, Rc)))
Cells(Rc + 1, Rc + 1).Value = T
Cells(Rc + 1, Rc + 1).Select
Selection.Font.ColorIndex = 10
'Kappa, S1, S2, S3
Xii = 0
Xip = 0
Xpi = 0
K = 0
S1 = 0
S2 = 0
S3 = 0
S4 = 0
SS1 = 0
SS2 = 0
SS3 = 0
SS4 = 0
For C = 1 To Rc
WS2.Select
Xii = Cells(C, C)
Xip = Cells(Rc + 1, C)
Xpi = Cells(C, Rc + 1)
SS1 = SS1 + Xii
SS2 = SS2 + (Xip * Xpi)
SS3 = SS3 + Xii * (Xip + Xpi)
Next C
K = (T * SS1 - SS2) / (T ^ 2 - SS2)
S1 = SS1 / T
S2 = SS2 / T ^ 2
S3 = SS3 / T ^ 2
'S4
Xij = 0
Xjp = 0
Xpi = 0
For C = 1 To Rc
For R = 1 To Rc
Xij = Cells(C, R)
Xjp = Cells(Rc + 1, R)
Xpi = Cells(C, Rc + 1)
SS4 = SS4 + Xij * (Xjp + Xpi) ^ 2
Next R
Next C
S4 = SS4 / T ^ 3
'Sigma
P1 = 0
P2 = 0
P3 = 0
P1 = (S1 * (1 - S1)) / (1 - S2) ^ 2
P2 = 2 * (1 - S1) * (2 * S1 * S2 - S3) / (1 - S2) ^ 3
P3 = (1 - S1) ^ 2 * (S4 - 4 * S2 ^ 2) / (1 - S2) ^ 4
Sig = Sqr((1 / T) * (P1 + P2 + P3))
'Display
WS2.Cells(Rc + 4, 1).Value = "Kappa"
WS2.Cells(Rc + 6, 1).Value = "S1"
WS2.Cells(Rc + 7, 1).Value = "S2"
WS2.Cells(Rc + 8, 1).Value = "S3"
WS2.Cells(Rc + 9, 1).Value = "S4"
WS2.Cells(Rc + 11, 1).Value = "Sigma"
WS2.Cells(Rc + 4, 2).Value = K
WS2.Cells(Rc + 6, 2).Value = S1
WS2.Cells(Rc + 7, 2).Value = S2
WS2.Cells(Rc + 8, 2).Value = S3
WS2.Cells(Rc + 9, 2).Value = S4
WS2.Cells(Rc + 11, 2).Value = Sig
WS3.Select
WS3.Cells(3, 4).Value = K
WS3.Cells(5, 4).Value = Sig
End Sub

Sub Get_Z()
Kappa1
Kappa2
End Sub

kappa係数算出マクロ

Excelファイルの画面

マクロの使用方法について

ご使用にあたって

VBA script