Excel VBAで相関行列と偏相関行列をまとめて出力する実行プログラムを作ってみた

昨年末までに偏相関係数を求める関数を作ってみたわけですが、変数が多くなってくると入力が面倒だし、表形式でまとめて見たいときもありますよね。
そこで、以下二つの記事で作ったソースコードをちょちょいと弄って、実行プログラムにしてみました。
Excel VBAで分析ツールの相関行列に無相関検定をちょい足ししてみた２ - 静粛に、只今統計勉強中
 Excel VBAで偏相関係数を求める関数を作ってみた３ - 静粛に、只今統計勉強中

ソースコード
コードの解説
使い方

ソースコード

'相関行列と偏相関行列及び無相関検定の結果を出力する
Sub Correl_Matrix()

    Dim α                      '有意水準
    Dim df()                    '自由度
    Dim h, i, j, k
    Dim Cols                    '要素数
    Dim Col()                   '項目名
    Dim Mat1(), Mat2, Mat3()    '相関行列・逆行列・偏相関行列
    Dim Rng1, Rng2              '相関係数を計算するセル範囲
    Dim CF
    Dim et
    
    α = InputBox("有意水準αを1～10％の範囲で数字のみ入力してください。" & vbCrLf & _
        vbCrLf & "α＝0.05(5%) の場合の入力例 ： 5", "相関行列＋無相関検定")

    Select Case α
    Case 1 To 10
        Application.ScreenUpdating = False  '表示を止める
        Cols = Selection.Columns.Count      '要素数に変数の数を代入
        ReDim df(1 To Cols, 1 To Cols)      '自由度の要素数と次元数を確定
        ReDim Col(1 To Cols)                '項目名の要素数と次元数を確定
        ReDim Mat1(1 To Cols, 1 To Cols)    '相関行列の要素数と次元数を確定
        ReDim Mat3(1 To Cols, 1 To Cols)    '偏相関行列の要素数と次元数を確定
    
        'Mat1（相関行列）に各列の相関係数を代入
        With Selection
            For i = 1 To Cols
                Col(i) = Selection(1, i) '項目名を代入
                Rng1 = .Offset(, i - 1).Resize(, 1)
                For j = 1 To Cols
                    Rng2 = .Offset(, j - 1).Resize(, 1)
                    Mat1(i, j) = WorksheetFunction.Correl(Rng1, Rng2)
                    df(i, j) = Pairwise(.Offset(, i - 1).Resize(, 1), _
                        .Offset(, j - 1).Resize(, 1), .Rows.Count) - 2
                Next
            Next
        End With
        
        Mat2 = WorksheetFunction.MInverse(Mat1) 'Mat2に相関行列の逆行列を代入
    
        'Mat3（偏相関行列）に偏相関係数を代入
        For i = 1 To Cols
            For j = 1 To Cols
                '偏相関係数＝逆行列の要素を2つの対角要素の積の平方根で割り，符号を逆転
                Mat3(i, j) = (Mat2(i, j) / Sqr(Mat2(i, i) * Mat2(j, j))) * -1
            Next
        Next
        
        Sheets.Add    'シートを追加
        
        With Range("A1")
            .Value = "相関行列"
            .Offset(1).Resize(Cols) = WorksheetFunction.Transpose(Col)
            .Offset(, 1).Resize(, Cols) = Col
            With .Offset(Cols + 2)
                .Value = "偏相関行列"
                .Offset(1).Resize(Cols) = WorksheetFunction.Transpose(Col)
                .Offset(, 1).Resize(, Cols) = Col
            End With
        End With
        
        With Range("B2").Resize(Cols, Cols)
            .Value = Mat1
            .NumberFormatLocal = "0.000"
            With .Offset(Cols + 2)
                .Value = Mat3
                .NumberFormatLocal = "0.000"
            End With
        End With
        
        With Range(Cells(1, 1), Cells(1, Cols + 1))
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            With .Offset(Cols).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Offset(Cols + 2)
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                With .Offset(Cols).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
            End With
        End With
        Cells.EntireColumn.AutoFit    '列幅を調整
        
        For h = 1 To 2
            et = (Cols + 2) * (h - 1)
            For i = 2 To Cols + 1
                With Cells(i + et, i)
                    .Font.Color = vbWhite
                    .Interior.Color = vbBlack
                    .Value = Abs(.Value)
                End With
            Next
            k = 2
            For i = 3 To Cols + 1
                For j = 2 To k
                    Cells(j + et, i) = _
                        WorksheetFunction.T_Dist_2T((Abs(Cells(i + et, j)) _
                        * Sqr(df(i - 2, j - 1))) / Sqr(1 - Cells(i + et, j) ^ 2), _
                            df(i - 2, j - 1))
                    If Cells(j + et, i) < α / 100 And Abs(Cells(i + et, j)) _
                        > 0.2 Then
                        With Cells(i + et, j)
                            .Font.Size = .Font.Size - 1
                            .Font.Bold = True
                            CF = Formatting(.Value)
                            .Font.Color = CF(0)
                            .Interior.Color = CF(1)
                            Cells(j + et, i).Interior.Color = CF(1)
    
                        End With
                    End If
                Next
                k = k + 1
            Next
        Next
        Application.ScreenUpdating = True '表示を再開する
    Case vbNullString
    Case Else
        MsgBox "有意水準αを1～10％の範囲で数字のみ入力してください。" & vbCrLf & _
            vbCrLf & "α＝0.05(5%) の場合の入力例 ： 5", vbCritical, _
            "相関行列＋無相関検定"
    End Select

End Sub

'ペアワイズした観測数ｎを求める
Private Function Pairwise(Arg1, Arg2, Arg3)

    Dim i, cnt

    For i = 1 To Arg3
        If IsNumeric(Arg1(i)) And IsNumeric(Arg2(i)) Then cnt = cnt + 1
    Next
    Pairwise = cnt

End Function

'相関係数の値に応じて色指定
Private Function Formatting(Arg)

    Select Case Arg
        Case Is < -0.7: Formatting = Array(vbRed, 9737946)
        Case Is < -0.4: Formatting = Array(vbRed, 12040422)
        Case Is < -0.2: Formatting = Array(vbRed, 14408946)
        Case Is > 0.7:  Formatting = Array(vbBlue, 14470546)
        Case Is > 0.4:  Formatting = Array(vbBlue, 15261367)
        Case Is > 0.2:  Formatting = Array(vbBlue, 15986394)
    End Select

End Function

コードの解説

けっこう縦に長いソースになってしまいましたが、コードの横や上にコメントを付けて要点がわかるようにしてありますので、コメントが付いていないところだけサックリと解説していきます。

インプットボックスでユーザーに有意水準を入力してもらい、値が１から１０の間だったときだけプログラムを実行します。
変数のペアごとに欠損値をペアワイズ除去した自由度を格納します。
offsetとresizeを使ってセル範囲を配列変数と同じ列数に整え、ワークシートに項目名（Col）を貼り付けます。
上と同様にセル範囲の行数・列数を整え、ワークシートに相関行列（Mat1）と偏相関行列（Mat3）を貼り付けます。
２つの表に罫線を引きます。
無相関検定をします。元の行列が対称行列であることを利用してセルの行・列を指定する変数 i と j を入れ替え、対角線の右上側にｐ値を出力していきます。

ここが本プログラムの肝ですね。
あ、画像ではｐ値出力のところ、自由度が df になっちゃってますが、正しくは df(i - 2, j - 1) です。すみませんが、ソースコードでご確認ください。