'Begin Description 'После установки значений верхней и нижней границы, ячейки мобильной таблицы будут 'закрашены в зависимости от того, в какую часть отрезков, определённых границами, 'попадает их содержимое. Все ячейки со значениями выше верхней границы закрашиваются 'зелёным фоном. Ниже нижней - красным. Значения между двумя границами - жёлтым. 'Условия: перед запуском скрипта обрабатываемая таблица должна быть выделена пользователем 'End Description '********************************************************** 'Создан в 1997 году, автор: Bernhard Witt - SPSS Germany '********************************************************** 'Исходный скрипт изменён Рейналем Левеком (Raynald Levesque rlevesque@videotron.ca). 'Скрипт не использует диалоговое окно, значения границ .15 и .25 указаны в коде скрипта. 'При необходимости пользователь может установить другие значения (между строками с метками ######### ниже). 'Перевод: А. Балабанов, 14.01.2009. 'Проверено: SPSS 15.0.0. 'Размещение: http://www.spsstools.ru/Script/PivotTables/TrafficLightFixed15and25.txt (.sbs). Option Explicit Const TextTotalStr ="Total" Const TextTotalStr2 ="Gesamt" Const red = RGB(178,34,34)'настройки красного цвета Const green = RGB(60, 179, 113)'настройки зеленого цвета Const white = RGB(255,255,255)'настройки белого цвета Const yellow = RGB(255,255,128)'настройки желтого цвета '### код для диалоговых окон удалён - А.Б. Sub Main Dim oben As String, unten As String '#################################### oben=".25" unten=".15" '#################################### Dim objItem As ISpssItem ' объект окна результатов Dim objPivotTable As PivotTable ' объект-мобильная таблица. Dim bolFoundOutputDoc As Boolean Dim bolPivotSelected As Boolean 'Вызов процедуры GetFirstSelectedPivot для установки ссылки на первую выделенную мобильную таблицу Call GetFirstSelectedPivot(objPivotTable, objItem, bolFoundOutputDoc, bolPivotSelected) If (bolFoundOutputDoc = False) Or (bolPivotSelected = False) Then 'либо нет открытых окон результатов, либо таблица не выделена Exit Sub End If Dim objDataCells As ISpssDataCells Dim lngNumRows As Long Dim lngNumColumns As Long Set objDataCells = objPivotTable.DataCellArray ' Осуществляем цикл по ячейкам и закрашиваем в соответствии с заданными границами Dim objRowLabels As ISpssLabels ' массив меток строк Set objRowLabels = objPivotTable.RowLabelArray Dim objColLabels As ISpssLabels ' массив меток столбцов Set objColLabels = objPivotTable.ColumnLabelArray lngNumRows = objDataCells.NumRows lngNumColumns = objDataCells.NumColumns Dim I As Integer, J As Integer objItem.Deactivate For I = 0 To lngNumRows -1 Dim dummy As Integer If InStr (objRowLabels.ValueAt(I,objRowLabels.NumColumns-1), TextTotalStr)= 0 And InStr (objRowLabels.ValueAt(I,objRowLabels.NumColumns-1), TextTotalStr2)= 0 Then For J = 0 To lngNumColumns -1 If InStr (objColLabels.ValueAt(objColLabels.NumRows-1,J), TextTotalStr)= 0 And InStr (objColLabels.ValueAt(objColLabels.NumRows-1,J), TextTotalStr2)= 0 Then If Len(objDataCells.ValueAt (I,J)) > 0 Then If objDataCells.ValueAt (I,J) <= Val(unten) Then objDataCells.BackgroundColorAt (I,J) = red Else If objDataCells.ValueAt (I,J) >= Val(oben) Then objDataCells.BackgroundColorAt (I,J) = green Else objDataCells.BackgroundColorAt (I,J) = yellow End If End If Else objDataCells.BackgroundColorAt (I,J) = white End If End If Next Else ' objDataCells.BackgroundColorAt (I,J) = white 'при желании в прочих случаях можем красить белым цветом - А.Б. End If Next ' деактивация мобильной таблицы и выход objItem.Activate objItem.Deactivate End Sub