Округление частот в перекрёстных таблицах до заданного разряда

 

Загрузить как .sbs Показать простым текстом

 

 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
'Автор: rolf.kjoeller@get2net.dk (Rolf Kjoeller)
'Размещено в comp.soft-sys.stat.spss
'Тема: округление частотных показателей в ячейках таблиц сопряжённости (crosstables)
'Дата: четверг, 26 августа, 1999, 09:30:20 по Гринвичу

'Ещё одно решению на тему округления значений. Скрипт берёт последнюю мобильную таблицу
'и округляет числовые значения, стоящие в ячейках данных, до заданного пользователем разряда.
'После этого он пытается пересчитать итоговые суммы по строкам и столбцам (соответственно,
'для последних столбца и строки). Скрипт работает в предположении, что обрабатываемая таблица
'является перекрёстной таблицей сопряжённости и содержит только абсолютные частоты....

'Можно огруглять и процентные показатели, но при этом суммы процентов могут быть пересчитаны некорректно.
'Аналогичное решение для процентов, http://www.spsstools.net/Scripts/PivotTables/RoundPercentagesCrosstable.txt,
'как будто, не имеет принципиальных отличий от данного - примеч. перев.

'Перевод: А. Балабанов, 12.01.2009.
'Проверено: SPSS 15.0.0.
'Размещение: http://www.spsstools.ru/Scripts/PivotTables/RoundFrequenciesInCrosstabTables.txt (.sbs).

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$("Округлить до:","Округление частот в ячейках","1")
If strRoundValue = "" Then GoTo UserCancel
lngRoundValue = CLng(strRoundValue)

'поиск последней мобильной таблицы в назначенном окне выдачи:
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

	'округление значений в ячейках:
	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
	
	'пересчёт сумм по строкам:
	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

	'пересчёт сумм по столбцам:
	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