Italize percentages in PivotTable

 

Download as .sbs Shows as plain text

 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
'Title:
'Italize percentages in Pivot Tables

'Begin Description
'Italize percentages contained in all Pivot Tables. See the 4 constants defined
'after the Option Explicit for other fonts options
'Script can also be used to change background color of those cells
'Posted to SPSSX-L list by Raynald Levesque on 2004/11/13
'End Description

Option Explicit

'Use of of the following constants in the "Call ChangeTextStyle()" line
Const cNORMAL=0
Const cITALIC=1
Const cBOLD=2
Const cBOLDITALIC=3

Option Explicit

Sub Main
	Dim objPivot As PivotTable
	Dim objItem As ISpssItem
	
	Do While GetNextPivot(objPivot, objItem)
		'postpone drawing until we're finished
		objPivot.UpdateScreen = False
		Call ChangeTextStyle(objPivot, "%", cITALIC, vbWhite)
		'Call ChangeTextStyle(objPivot, "%", cNORMAL, vbYellow)
		objPivot.UpdateScreen = True
		objPivot.Autofit
		objItem.Deactivate
		objItem.ActivateTable 'to ensure table is updated correctly
		objItem.Deactivate    'to ensure table is updated correctly
	Loop
End Sub

Sub ChangeTextStyle(objPivot As PivotTable, strNeedle As String , intTextStyle As Integer, lngBackColor As Long)
	Dim lngRow As Long, lngCol As Long
	Dim objDataCells As ISpssDataCells
	Dim strFormat As String
	Set objDataCells = objPivot.DataCellArray
		With objDataCells
			For lngRow = 0 To .NumRows - 1
				For lngCol = 0 To .NumColumns - 1
				strFormat = .NumericFormatAt(lngRow,lngCol)
				If Not IsNull (.ValueAt (lngRow, lngCol)) And InStr(strFormat,strNeedle)>0 Then
					.TextStyleAt(lngRow,lngCol)= intTextStyle
					.BackgroundColorAt(lngRow,lngCol)= lngBackColor
				End If
				Next
			Next
		End With
	objPivot.Autofit
End Sub


Function GetNextPivot(objPivot As PivotTable, objItem As ISpssItem) As Boolean
'Purpose: Find each Pivot Table in turn
'Assumptions: A Pivot Table is in the Output Doc (Navigator); output doesn't change between calls
'Effects: each time the procedure is called, it activates the next selected Pivot Table
'Inputs: PivotTable object, Item object that contains selected PivotTable
'Return Values: activated PivotTable, Item in the Navigator, function value is True if a pivot table is found
'This sub was written by SPSS

	Static objDocuments As ISpssDocuments  	' SPSS documents.
	Static objOutputDoc As ISpssOutputDoc   ' Output document
	Static objItems As ISpssItems       	' Output Navigator items 
	Static intItem As Integer 		   		' Output Navigator item's index 
	Static intItemCount As Integer			' total number of items in the navigator
	
	Dim intItemType As Integer
	Dim bolSelected As Boolean             	' True if an item is selected.
	Dim bolReset As Boolean
	Dim i As Integer

	' initialize the return values
	GetNextPivot = False
	Set objPivot = Nothing
	Set objItem = Nothing
		
	' if this is the first call, set a flag to initialize things
	If (objDocuments Is Nothing) Or (objOutputDoc Is Nothing) Or (objItems Is Nothing) Then
		bolReset = True
	End If
		
	If bolReset Then
		'Get list of documents in SPSS.
		Set objDocuments = objSpssApp.Documents
	End If	' done with the document collection
	
	If bolReset Then
		' Get designated document only if there is at least one output document.
		If objDocuments.OutputDocCount > 0 Then
		   'Get the currently designated output document.
		   Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc
		Else
			'If no navigator window exists.
			MsgBox( "No navigator document found." )
			Exit Function
		End If
	End If	' done with outputdoc
	
	' Get the outline tree and the number of items:
	If bolReset Then
		Set objItems = objOutputDoc.Items
		intItemCount = objItems.Count
	End If
	
	' there will be problems if anything failed, just make sure
	If (objDocuments Is Nothing) Or (objOutputDoc Is Nothing) Or (objItems Is Nothing) Then
		Debug.Print "objDocuments Is Nothing: " & (objDocuments Is Nothing)
		Debug.Print "objOutputDocIs Nothing: " & (objOutputDoc Is Nothing)
		Debug.Print "objItems  Is Nothing: " & (objItems Is Nothing)
		MsgBox "There was a problem with the Navigator document.", vbExclamation, "GetNextPivot"
		Exit Function
	End If
	
	' a simple check that output hasn't changed
	If intItemCount <> objItems.Count Then
		MsgBox "Output changed while Script was running.", vbExclamation, "GetNextPivot"
		Exit Function
	End If
	
	If bolReset Then
		intItem = 0
	End If
	
	' Get the next pivot table.
	For i = intItem To intItemCount - 1
		Set objItem = objItems.GetItem(i)
		intItemType = objItem.SPSSType
		If intItemType = SPSSPivot Then 
			intItem = i + 1								' start here next time
			Set objPivot = objItem.ActivateTable()  	'Activate the pivot table.
			GetNextPivot  = True	                  	' We did find a pivot table.
			Exit For                                  	' Exit the loop.
        End If
	Next i
	
	If GetNextPivot = False And intItem = 0 Then
		'No pivot table was found.
		MsgBox( "There are no Pivot Tables in the output." )
		Exit Function
	End If

End Function
Related pages

...

Navigate from here