Алексей Гладкий - Excel. Трюки и эффекты

If Not IsEmpty(Values(i)) And Values(i) <> 0 Then _

varOut = varOut + 1

Case dhcCountPlus

' Подсчет количества положительных значений

If Values(i) > 0 Then varOut = varOut + 1

Case dhcCountMinus

' Подсчет количества отрицательных значений

If Values(i) < 0 Then varOut = varOut + 1

End Select

Next i

' Окончательные операции для некоторых видов расчета

If intMode = dhcAvg Then

' Вычисление среднего значения

ColorCalc = varOut / intCount

Else

ColorCalc = varOut

End If

End Function

В приведенном выше коде реализованы следующие элементы:

• функция ColorCalc – выполняет все расчеты с использованием цвета (параметры этой функции и ее аргументы рассматриваются в следующем разделе);

• макрос CalcColors – отображает форму управления расчетом (см. ниже).

В проект VBA необходимо также добавить форму и поместить в ее модуль код, приведенный в листинге 5.6.

Dim lngCurColor As Long ' Выбранный цвет, по которому _

идентифицировать (отбирать) ячейки

Dim intMode As Integer ' Номер типа вычисления в списке

Sub cmbApplyColor_Click()

If cboOtherColor.Value >= 0 Then

' Вычисление с использованием выбранного в списке цвета

lngCurColor = cboOtherColor.Value

SetColorSum

End If

End Sub

Sub cmbColor1_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor1.BackColor

SetColorSum

End Sub

Sub cmbColor2_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor2.BackColor

SetColorSum

End Sub

Sub cmbColor3_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor3.BackColor

SetColorSum

End Sub

Sub cmbColor4_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor4.BackColor

SetColorSum

End Sub

Sub cmbColor5_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor5.BackColor

SetColorSum

End Sub

Sub cmbColor6_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor6.BackColor

SetColorSum

End Sub

Sub cmbColor7_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor7.BackColor

SetColorSum

End Sub

Sub cmbColor8_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor8.BackColor

SetColorSum

End Sub

Sub cmbColor9_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor9.BackColor

SetColorSum

End Sub

Sub cmbColor10_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor10.BackColor

SetColorSum

End Sub

Sub cmbColor11_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor11.BackColor

SetColorSum

End Sub

Sub cmbColor12_Click()

' Вычисление с использованием цвета нажатой кнопки

lngCurColor = cmbColor12.BackColor

SetColorSum

End Sub

Sub SetColorSum()

' Вычисление с использованием заданного цвета

Dim strFormula As String

' Проверка правильности введенных диапазонов и номеров ячеек

If txtResCell.Value = "" Then

MsgBox «Введите адрес ячейки вставки функции», _

vbCritical, «Внимание!»

txtResCell.SetFocus

Exit Sub

ElseIf txtRange.Value = "" Then

MsgBox «Введите адрес диапазона суммирования», _

vbCritical, «Внимание!»

txtRange.SetFocus

Exit Sub

End If

' Формирование формулы

strFormula = "=ColorCalc(" & """"& txtRange.Value & """" _

& "," & lngCurColor & "," & CInt(tglType.Value) & "," _

& intMode & "," & CInt(chkVarify.Value) & ")"

' Запись формулы в ячейку

Range(txtResCell.Value).Formula = strFormula

End Sub

Sub cmbExit_Click()

' Закрытие формы

Unload Me

End Sub

Sub cboCalcTypes_AfterUpdate()

' Изменение режима вычисления – сохраним в переменной _

номер вычисления

intMode = cboCalcTypes.ListIndex

End Sub

Sub cboOtherColor_Change()

' Изменение выделенного цвета в списке «Другой»

If cboOtherColor.Text <> "" Then

' Сохранение выбранного цвета в переменной

lngCurColor = Val(cboOtherColor.Value)

End If

End Sub

Sub tglType_Click()

' Изменение типа идентификации ячеек

If tglType.Value = -1 Then

' Идентификация по цвету заливки

tglType.Caption = «Заливка»

Else

' Идентификация по цвету шрифта

tglType.Caption = «Шрифт»

End If

GetColors

End Sub

Sub txtRange_AfterUpdate()

' Изменение диапазона с исходными данными – покажем _

кнопки с цветами, представленными в новом диапазоне

GetColors

End Sub

Sub txtRange_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)

' Проверка корректности данных, введенных в поле _

диапазона исходных данных

Dim rgData As Range

Dim cell As Range

' Проверка, введен ли диапазон данных

If txtRange.Text = "" Then

MsgBox «Введите адрес диапазона суммирования!», _

vbCritical, «Ошибка выполнения»

Cancel = True

End If

If txtResCell.Text = "" Then Exit Sub

On Error GoTo Err1

' Проверка отсутствия циклических ссылок (чтобы одна _

из входных ячеек не была одновременно и выходной)

Set rgData = Range(txtRange.Text)

For Each cell In rgData.Cells

If cell.Address(False, False) = _

Range(txtResCell.Text).Address(False, False) Then

' Нашли циклическую ссылку

MsgBox "Введите другой адрес во избежание " & _

«появления циклических ссылок», vbCritical, _