Автоскрипт для форматирования таблицы с корреляциями

'#Language "WWB-COM"

'Begin Description
'This code
'  removes the Upper diagonal of the correlation matrix
'  highlights significant correlations
'  moves the statistics to the Layer dimension (thus hiding N's and Sig's)
'Instructions: Replace the Sub Correlations_Table_Correlations_Create by the Subs and Function below.
'Author: Ferd Britton 2003/08/08
'Adapted for version IBM SPSS Statistics 23.0 by Anton Balabanov, 18.06.2016
'(you will need to link to this script in SPSS Edit...Options menu, Scripts tab:
' enable autoscripting, and select Correlations, and Correlations Table, then link to a file)
'End Description

Option Explicit

Sub Main
'Autoscript
'Trigger Event: Correlations Table Creation after running Correlations procedure.
	Dim lngVarGroup As Long		'keeps track of how many rows in a variable group
	Dim i, intCount As Integer
	Dim objOutputItem As ISpssItem
	Dim objCorrPivotTable As PivotTable
	Dim objDataCells As ISpssDataCells
	Dim objmanager As ISpssPivotMgr
	Dim objRow As ISpssDimension
	Set objOutputItem = scriptContext.GetOutputItem()
	Set objCorrPivotTable = objOutputItem.ActivateTable
	Set objDataCells = objCorrPivotTable.DataCellArray
	If (objDataCells.NumRows Mod objDataCells.NumColumns) = 0 Then
		'Set flag so that screen is not updated while we make changes
		'NOTE:THIS MUST BE SET BACK TO TRUE AT THE END OF THE AUTOSCRIPT
		objCorrPivotTable.UpdateScreen = False

		lngVarGroup = GetVarGroupSize(objCorrPivotTable)
		'if -1 then couldn't determine group size
		If lngVarGroup <> -1 Then
			'Procedure that removes upper diagonal of correlation matrix
			Call RemoveUpperDiag(objCorrPivotTable,objDataCells,lngVarGroup)
			'Procedure that highlights significant correlations
			Call HighlightSigCorr(objCorrPivotTable, objDataCells, lngVarGroup)
		End If

		'Set flag so that screen is updated so we can view changes

	End If

	Set objmanager =objCorrPivotTable.PivotManager
	intCount = objmanager.NumRowDimensions
		For i = 0 To intCount -1
			Set objRow = objmanager.RowDimension(i)
			If objRow.DimensionName  = "Statistics" Then
				objRow.MoveToLayer(0)
			Exit For
			End If
		Next i
		objCorrPivotTable.UpdateScreen = True

End Sub

Sub RemoveUpperDiag(objPivotTable As PivotTable, objDataCells As ISpssDataCells, lngVarGroupSize As Long)
'Purpose: Removes the upper diagonal of a correlation matrix Pivot Table.
'Assumptions: The correlations Pivot Table is already activated
'Effects: Hides all data cells on or above the diagonal in the correlation, significance,
'  and N matrices of a Correlations Pivot Table
'Inputs: Correlations Pivot Table, DataCells for Correlations Pivot Table, lngVarGroupSize
'  determines how many rows until repeat labels
'Return Values: Reformatted Correlations Pivot Table

    Dim lngRowNum As Long
    Dim lngColNum As Long
    Dim lngNumCols As Long
    Dim lngNumRows As Long

    'Get number of rows and columns in Pivot Table
    lngNumCols = objDataCells.NumColumns
    lngNumRows = objDataCells.NumRows

    'This loop selects all cells above the diagonal in the correlation, significance, and N matrices
    For lngRowNum = 0 To lngNumRows - 1
        For lngColNum = 0 To lngNumCols - 1
            If (lngColNum >= ((Int(lngRowNum/lngVarGroupSize)) Mod lngNumCols)) Then
                   objDataCells.SelectCellAt(lngRowNum, lngColNum)
            End If
        Next lngColNum
    Next lngRowNum

    'Now hide all the cells that were selected
    objPivotTable.TextHidden = True

    'Deselect all the cells that had been selected
    objPivotTable.ClearSelection

End Sub

Sub HighlightSigCorr(objPivotTable As PivotTable, objDataCells As ISpssDataCells, lngVarGroupSize As Long)
'Purpose: Highlights significant correlations
'Assumptions: The correlations Pivot Table is already activated
'Effects: Changes the background color for cells in correlation matrix that are significant.
'Inputs: Correlations Pivot Table, DataCells for Correlations Pivot Table, lngVarGroupSize
' determines how many rows until repeat labels
'Return Values: Pivot Table with significant correlations highlighted.

    Dim lngRowNum As Long
    Dim lngColNum As Long
    Dim lngNumCols As Long
    Dim lngNumRows As Long
    Dim lngColor As Long
    Dim sngSigLevel As Single
    Dim bolCellsSelected As Boolean

	bolCellsSelected = False

    Set objDataCells = objPivotTable.DataCellArray()

 	'Obtain Dimensions of Correlation Pivot Table.
    lngNumCols = objDataCells.NumColumns
    lngNumRows = objDataCells.NumRows

	'Set the value for the Background Color.
    lngColor = RGB (255, 255, 128) 	'Yellow

	'Set Significance Level.
    sngSigLevel = .01

	'Loop through Pivot Table. Change the color of the current cell conditional upon the
    'value of the element lngNumCols below it. The cells to be changed are selected using
    'the SelectCellAt method. The color is changed afterwards with the BackgroupColorAt
    'Property.
    For lngRowNum = 0 To lngNumRows - 1 Step lngVarGroupSize
        For lngColNum = 0 To lngNumCols - 1
            If (lngColNum < ((Int(lngRowNum/lngVarGroupSize)) Mod lngNumCols)) Then
            If objDataCells.ValueAt(lngRowNum + 1, lngColNum)< sngSigLevel Then
            	objDataCells.SelectCellAt(lngRowNum, lngColNum)
            	bolCellsSelected = True
            End If
            End If
        Next lngColNum
    Next lngRowNum

	'Change the Background Color of the Selected Cells.
	If bolCellsSelected = True Then
		objPivotTable.BackgroundColor = lngColor
	End If

End Sub

Function GetVarGroupSize(objPivotTable As Object) As Long
'Purpose: To get the number of rows per variable in the correlation table
'Assumptions: The correlations Pivot Table is already activated
'Effects: None
'Inputs: Correlations Pivot Table
'Return Values: The number of rows in each group.
	Const FIRST_ROW As Long = 0

	Dim objRowLabels As ISpssLabels
	Dim lngRowNum As Long
	Dim strFirstRowLabel As String
	Dim lngLastCol As Long
	Dim bolFoundMatch As Boolean

	Set objRowLabels = objPivotTable.RowLabelArray
	lngLastCol = objRowLabels.NumColumns - 1
	strFirstRowLabel = CStr(objRowLabels.ValueAt(FIRST_ROW,lngLastCol))
	bolFoundMatch = False

	'Try to find matching label to first row label -- that will give group size
	For lngRowNum = FIRST_ROW+1 To objRowLabels.NumRows - 1
		If CStr(objRowLabels.ValueAt(lngRowNum,lngLastCol)) = strFirstRowLabel Then
			bolFoundMatch = True
			Exit For
		End If
	Next lngRowNum

	If bolFoundMatch Then
		GetVarGroupSize = lngRowNum
	Else
		GetVarGroupSize = -1
	End If

End Function