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
'Begin Description
	'Скрипт проходит по содержимому окна результатов. В каждой найденной
	'мобильной таблице он ставит в пустые ячейки данных строковое значение,
	'определённое пользователем (символ или несколько символов).
'End Description

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

Option Explicit
'Здесь определяется строковая константа, значение которой будет подставляться в
'пустые ячейки данных. В данном случае - это набор символов *****.
'Источник: SPSS Script Library - Pivot Table Scripts (библиотека скриптов SPSS, раздел скриптов для обработки мобильных таблиц)

Const cVAL = "*****"

Sub Main
 Dim objDocuments As ISpssDocuments      ' коллекция документов SPSS.
 Dim objOutputDoc As ISpssOutputDoc      ' документ результатов (Output)
 Dim objItems As ISpssItems         ' коллекция объектов окна результатов (Output Navigator items)
 Dim objPivotTable As PivotTable   ' мобильная таблица (Pivot Table)
 Dim i As Integer

 'Ссылка на коллекцию документов SPSS.
 Set objDocuments = objSpssApp.Documents

 ' Ставим ссылку на документ окна результатов только после проверки, что есть открытые окна результатов.
 ' Иначе может произойти ошибка.
 If objDocuments.OutputDocCount > 0 Then
    'ссылка на назначенное окно результатов
    Set objOutputDoc = objSpssApp.GetDesignatedOutputDoc
 Else
  'Если нет ни одного окна результатов, выходим из скрипта.
  'Чтобы избежать появления сообщения об этом, закомментируйте следующую строку.
  MsgBox "Пожалуйста, создайте окно результатов перед запуском скрипта.", vbExclamation, "Ошибка выполнения скрипта"
  Exit Sub
 End If

 ' ссылка на дерево (коллекцию) объектов окна результатов
 Set objItems = objOutputDoc.Items
 Dim objItem As ISpssItem

 ' поочерёдно обрабатываем каждый объект в окне результатов
 For i = 0 To objItems.Count - 1
  	Set objItem = objItems.GetItem(i) 'ссылка на очередной объект
	If objItem.SPSSType = SPSSPivot Then	  'проверяем, что объект является мобильной таблицей
	   Set objPivotTable = objItem.ActivateTable()	   'активируем мобильную таблицу
	   'objPivotTable.UpdateScreen = False	   'откладываем перерисовку таблицы на потом

	    Call ReplaceEmptyCells(objPivotTable)
		objPivotTable.UpdateScreen = True
	 	objItem.Deactivate
    End If
 Next
End Sub

Sub ReplaceEmptyCells (objPivotTable As PivotTable)

        Dim objDataCells As ISpssDataCells
        Dim lngRowNum As Long
        Dim lngColNum As Long
        Dim lngNumCols As Long
        Dim lngNumRows As Long

	'получаем ссылку на массив ячеек с данными

    Set objDataCells = objPivotTable.DataCellArray()
    lngNumCols = objDataCells.NumColumns
    lngNumRows = objDataCells.NumRows
    For lngRowNum = 0 To lngNumRows - 1
        For lngColNum = 0 To lngNumCols - 1

	        'Далее мы, при условии, что ячейка данных вовсе пуста, или содержит пустую строку,
	        'ставим в неё значение строковой константы cVAL, которое определено выше

	        If  (IsNull(objDataCells.ValueAt(lngRowNum, lngColNum))) Then
	                        objDataCells.ValueAt(lngRowNum,lngColNum) = cVAL
							objDataCells.HAlignAt(lngRowNum, lngColNum)= 4
		    			   	'В предыдущей строке мы выравниваем вновь вставленное значение
		       				'в соответствии со следующими константами выравнивания:
							'0 	SpssHAILeft (влево)
							'1	SpssHAlRight (вправоt)
							'2	SpssHAlCenter (по центру)
							'3	SpssHAlMixed (смешанное) - в соответствии с типом данных - примеч. перев.
							'4	SpssHAlDecimal (по десятичной точке) - для значений с десятичной точкой - примеч. перев.
			ElseIf objDataCells.ValueAt(lngRowNum, lngColNum)="" Then '###
            				objDataCells.ValueAt(lngRowNum,lngColNum) = cVAL '### -  добавлено А.Б.
							objDataCells.HAlignAt(lngRowNum, lngColNum)= 1 '###
			End If
        Next lngColNum
    Next lngRowNum
End Sub