Round frequencies in crosstab tables

 

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
'From: rolf.kjoeller@get2net.dk (Rolf Kjoeller)
'Newsgroups: comp.soft-sys.stat.spss
'Subject: rounding of cellfrequencies In crosstables
'Date: Thu, 26 Aug 1999 09:30:20 GMT

'Here Is another take On the round-cellfrequencies-problem. The script
'will Do crazy things On anything but crosstables that contain only
'cellfrequencies, On the positive side it doesn't modify your data ...


Option Explicit

Sub Main
On Error GoTo UserCancel
Dim objOutputDoc As ISpssOutputDoc
Dim objOutputItems As ISpssItems
Dim objOutputItem As ISpssItem
Dim objPivotTable As PivotTable
Dim objCells As ISpssDataCells
Dim strRoundValue As String
Dim lngRoundValue As Long, lngSum As Long
Dim lngII As Long, lngJJ As Long
Dim lngLastRow As Long, lngLastCol As Long
Dim intLastItem As Integer

strRoundValue = InputBox$("Round-value:","Round cell-frequencies to nearest integer")
If strRoundValue = "" Then GoTo UserCancel
lngRoundValue = CLng(strRoundValue)

'get the last pivottable:
Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc
Set objOutputItems = objOutputDoc.Items()
With objOutputItems
	intLastItem = .Count() - 1
	For lngII = intLastItem To 0 Step -1
		Set objOutputItem = .GetItem(lngII)
		If objOutputItem.SPSSType = SPSSPivot Then
			Set objPivotTable = objOutputItem.Activate()
			objpivottable.UpdateScreen = False
			Exit For
		End If
	Next lngII
End With

Set objCells = objPivotTable.DataCellArray
With objCells
	lngLastRow = .NumRows - 1
	lngLastCol = .NumColumns - 1

	'round the datacells:
	For lngII = 0 To lngLastRow
		For lngJJ = 0 To lngLastCol
			If Not IsNull(.ValueAt(lngII, lngJJ)) Then
	   		    .ValueAt(lngII, lngJJ) = CStr(Format(.ValueAt(lngII, lngJJ)/lngRoundValue, "0") * lngRoundValue)
			End If
		Next lngJJ
	Next lngII
	
	'recalc rowsums:
	For lngII = 0 To lngLastRow
		lngSum = 0
		For lngJJ = 0 To lngLastCol - 1
			If Not IsNull(.ValueAt(lngII, lngJJ)) Then
	   		    lngSum = lngSum + .ValueAt(lngII, lngJJ)
			End If
		Next lngJJ
		.ValueAt(lngII, lngLastCol) = CStr(lngSum)
	Next lngII

	'recalc colsums:
	For lngJJ = 0 To lngLastCol
		lngSum = 0
		For lngII = 0 To lngLastRow - 1
			If Not IsNull(.ValueAt(lngII, lngJJ)) Then
	   		    lngSum = lngSum + .ValueAt(lngII, lngJJ)
			End If
		Next lngII
		.ValueAt(lngLastRow, lngJJ) = CStr(lngSum)
	Next lngJJ
End With

objOutputItem.Deactivate
objOutputDoc.ClearSelection

UserCancel:
End Sub
Related pages

...

Navigate from here