kappa係数算出マクロ



Excelファイルの画面
マクロの使用方法について説明します。
  1. ファイルを開く際マクロを有効にして下さい（ウィルス・マクロでは決してありません）．
  2. ワークシートMatrix1にerror matrixをコピー．
  3. ワークシートMatrix2にerror matrixをコピー．
  4. ワークシートResultにある矢印を押す．
  5. 以上で終了です．

ダウンロード

ご使用にあたって
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