Option Explicit

Sub eigen_Ishii()

    Dim corr As Range, out As Range
    Dim a() As Double, e() As Double, v() As Double
    Dim n As Integer
    Dim r As Integer, c As Integer
    Dim Max_eigen As Double, ci As Double, W1 As Double, W2 As Double, W3 As Double

Do
        Set corr = Application.InputBox(prompt:="対象となる行列のセル範囲を指定:", _
                                        Title:="行列", Type:=8)
        n = corr.Rows.Count
        If n <= 0 Then
            MsgBox "範囲を指定してください"
        ElseIf n <> corr.Columns.Count Then
            MsgBox "正方行列でなくてはなりません"
        Else
            Exit Do
        End If
    Loop

 Do
        Set out = Application.InputBox(prompt:="結果の出力先（左上隅）を指定:", _
                                        Title:="計算結果の出力先", Type:=8)
        r = out.Row
        c = out.Column
        If areacheck(r, c, n + 2, n + 1) = 0 Then
            Exit Do
        End If
        MsgBox "出力領域に空でないセルがあります。上書きされるおそれがあるので，別の領域を指定してください。"
Loop

    ReDim a(n, n)
    ReDim e(n)
    ReDim v(n, n)

    If restore2(a, corr, n, n) = False Then
        MsgBox "行列のうち，空白または数値以外の値の入ったセルがあります"
        Exit Sub
    End If
    
    Max_eigen = AHP(-1, n, a)
    ci = AHP(0, n, a)
    W1 = AHP(1, n, a)
    W2 = AHP(2, n, a)
    W3 = AHP(3, n, a)

    save2cell r, c, Max_eigen, ci, W1, W2, W3
    

End Sub

' 出力範囲に空セル以外があるかどうかのチェック

Function areacheck(i0 As Integer, j0 As Integer, n As Integer, m As Integer) As Integer
    Dim i As Integer, j As Integer
    areacheck = 0
    For i = i0 To i0 + 6
        For j = j0 To j0 + 1
            If Not IsEmpty(Cells(i, j)) Then
                areacheck = 1
                Exit Function
            End If
        Next j
    Next i
End Function

' 指定範囲の値を配列に代入

Function restore2(dest() As Double, src As Range, nr As Integer, nc As Integer) As Boolean
    Dim i As Integer, j As Integer
    For i = 1 To nr
        For j = 1 To nc
            If IsEmpty(src(i, j)) Or IsNumeric(src(i, j)) = False Then
                restore2 = False
                Exit Function
            End If
            dest(i, j) = src(i, j)
        Next j
    Next i
    restore2 = True
End Function

Sub save2cell(r As Integer, c As Integer, e As Double, ci As Double, W1 As Double, W2 As Double, W3 As Double)
    Dim i As Integer, j As Integer
    
    Cells(r, c) = "最大固有値"
    Cells(r, c + 1) = e
    
    Cells(r + 1, c) = "C.I."
    Cells(r + 1, c + 1) = ci
    
    Cells(r + 2, c) = "重要度（重み付け）"
    Cells(r + 3, c) = "W1"
    Cells(r + 3, c + 1) = W1
    Cells(r + 4, c) = "W2"
    Cells(r + 4, c + 1) = W2
    Cells(r + 5, c) = "W3"
    Cells(r + 5, c + 1) = W3
    
End Sub

'   AHP用関数
'   TP:出力  -1:λ（固有値）,0:CI , 1〜n:重要度
'   n:項目数
'   hikakuti(範囲): 一対比較行列のうち，実質的な部分（対角要素を除く右上の範囲）
' (C) 高萩栄一郎 2001-2007
' このプログラム（マクロ）は，授業，講習会等で配布してかまいません．
' また，必要に応じて，改変してもかまいません．

Function AHP(TP As Variant, n As Variant, hikakuti As Variant) As Variant

    Dim ttp As Integer
    Dim nn As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim ff As Integer
    Dim a() As Double
    Dim b() As Double
    Dim bb() As Double
    Dim tt As Double
    Dim lambda As Double
    Dim ci As Double
    Dim EPS As Double
    Dim MAX_LOOP As Integer
   
   EPS = 0.000000001       ' 最大固有値を計算するときの差異の許容値
   MAX_LOOP = 1000         '最大固有値を計算するときの最大の繰り返し回数
   
   
   
   
    'If n > 30 Then
    '    AHP = "nは30以下に設定してください"
    '    Exit Function
    'End If
 
    If (Val(n) <= 0) Then
        AHP = "nが設定されていないか負の値です"
        Exit Function
    End If

    ttp = TP
    nn = n
    ReDim a(nn, nn)
    ReDim b(nn)
    ReDim bb(nn)
    
    For i = 1 To nn
        bb(i) = 1 / n
    Next

    For i = 1 To nn
        a(i, i) = 1
        For j = i + 1 To nn
            a(i, j) = hikakuti(i, j)
            a(j, i) = 1 / a(i, j)
        Next
    Next
    
    '計算
    
    i = 0
    While (1)
        i = i + 1
        For j = 1 To nn
            b(j) = bb(j)
        Next
            '  行列のかけ算
        For j = 1 To nn
            bb(j) = 0
            For k = 1 To nn
                bb(j) = bb(j) + a(j, k) * b(k)
            Next
        Next
        lambda = bb(1) / b(1)
        
           ' 合計が1になるように計算
        tt = 0
        For j = 1 To n
          tt = tt + bb(j)
        Next
        For j = 1 To n
          bb(j) = bb(j) / tt
        Next
           ' すべての差がEPS以下もしくはルールがMAX_LOOP以上になったら終了
        ff = 0  ' 差がEPS以下かどうかのフラグ
        For j = 1 To n
          If ((Abs(bb(j) - b(j)) / b(j)) > EPS) Then
              ff = 1
          End If
        Next
        If ((ff = 0) Or (i > MAX_LOOP)) Then
           GoTo L1
        End If
    Wend
L1:
    ci = ((lambda - nn) / (nn - 1))
    
    AHP = ""
    If ttp = -1 Then
        AHP = lambda
    ElseIf ttp = 0 Then
        AHP = ci
    ElseIf (ttp >= 1 And ttp <= nn) Then
        tt = 0
        For i = 1 To nn
            tt = tt + bb(i)
        Next
        AHP = bb(ttp) / tt
    End If
End Function