相関行列を生成する

時々手作業で作ったりしてたのだがいい加減イラついたのでマクロを作成した．
変数名が日本語なのはスルーの方向で頼む．

前提として

• 元のデータはテーブルになっていること
• 「相関行列」という名前のシートやテーブルが他にないこと
• マクロ起動時にカーソルが元データのテーブルの上にあること

Sub 相関行列を作成()
    Dim 元テーブル As ListObject, 相関行列テーブル As ListObject
    
    Set 元テーブル = 元テーブルを特定
    Set 相関行列テーブル = Create相関行列テーブル(元テーブル)
    Call WriteTo相関行列テーブル(相関行列テーブル, 元テーブル)
    Call Set条件付き書式(相関行列テーブル)
    
    相関行列テーブル.HeaderRowRange(1).Select
End Sub

Private Function Count列数(元テーブル As ListObject) As Integer
    Count列数 = 元テーブル.HeaderRowRange.Count
End Function

Private Function 元テーブルを特定() As ListObject

    Dim 元テーブル As ListObject
    Set 元テーブル = ActiveCell.ListObject
    If 元テーブル Is Nothing Then
        MsgBox "テーブルの中にセルを置いてください．"
        Exit Function
    End If
    
    Set 元テーブルを特定 = 元テーブル
End Function

Private Function Create相関行列テーブル(元テーブル As ListObject) As ListObject
    Dim 相関行列シート As Worksheet
    Set 相関行列シート = Sheets.Add
    相関行列シート.Name = "相関行列"
    
    Dim 列数 As Integer
    列数 = Count列数(元テーブル)
    
    Set Create相関行列テーブル = 相関行列シート.ListObjects.Add(SourceType:=xlSrcRange, Source:=Range(Cells(1, 1), Cells(列数 + 1, 列数 + 1)), xlListObjectHasHeaders:=xlYes)
    With Create相関行列テーブル
        .Name = "相関行列"
        .TableStyle = "tablestylelight1"
        .ShowTableStyleFirstColumn = True
    End With
End Function

Private Sub WriteTo相関行列テーブル(相関行列テーブル As ListObject, 元テーブル As ListObject)

    With 相関行列テーブル
        .HeaderRowRange(1) = "."
        
        元テーブル.HeaderRowRange.Copy
        .HeaderRowRange(2).PasteSpecial Paste:=xlPasteValues, Transpose:=False
        .ListColumns(1).DataBodyRange.PasteSpecial Paste:=xlPasteValues, Transpose:=True
        
        Dim 列数 As Integer, i As Integer, j As Integer
        列数 = Count列数(元テーブル)
    
        For i = 1 To 列数
            For j = 1 To 列数
                Dim formulatext As String
                formulatext = "=correl(" & 元テーブル.Name & "[" & 元テーブル.HeaderRowRange(1, i) & "]," & 元テーブル.Name & "[" & 元テーブル.HeaderRowRange(1, j) & "])"
                .ListRows(i).Range(j + 1).Formula = formulatext
            Next j
        Next i
    End With
End Sub

Private Sub Set条件付き書式(相関行列テーブル As ListObject)

    With Range(相関行列テーブル)
        .FormatConditions.AddColorScale ColorScaleType:=3
        With .FormatConditions(1).ColorScaleCriteria(1)
            .Type = xlConditionValueLowestValue
            .FormatColor.Color = 13011546
        End With
        With .FormatConditions(1).ColorScaleCriteria(2)
            .Type = xlConditionValueNumber
            .Value = 0
            .FormatColor.Color = 16776444
        End With
        With .FormatConditions(1).ColorScaleCriteria(3)
            .Type = xlConditionValueHighestValue
            .FormatColor.Color = 7039480
        End With
    End With