Excel. Трюки и эффекты

Листинг 5.5. Код в стандартном модуле

Const dhcSum As Integer = 0

Const dhcAvg As Integer = 1

Const dhcMax As Integer = 2

Const dhcMin As Integer = 3

Const dhcCount As Integer = 4

Const dhcSumPlus As Integer = 5

Const dhcSumMinus As Integer = 6

Const dhcCountFull As Integer = 7

Const dhcCountNotNull As Integer = 8

Const dhcCountPlus As Integer = 9

Const dhcCountMinus As Integer = 10

Sub CalcColors()

' Отображение формы

Load frmColorCalc

frmColorCalc.Show

End Sub

Public Function ColorCalc(strRange As String, _

lngColor As Long, fBackBolor As Boolean, _

intMode As Integer, Optional fAbsence As Boolean) As Double

' Операции над ячейками с установленным цветом шрифта _

или заливки

Dim rgData As Range ' Диапазон ячеек для расчетов

Dim i As Integer

Dim Values() As Variant ' Массив со значениями для расчета

Dim intCount As Integer ' Количество значений в массиве

Dim cell As Range

Dim varOut As Variant ' В этой переменной хранятся _

результаты промежуточных подсчетов _ и окончательный результат

Set rgData = Range(strRange)

ReDim Values(1 To rgData.Count)

' Просматриваются все ячейки входного диапазона. Значения

тех из них, _

цвет которых удовлетворяет условию, записываются в массив

Values

For Each cell In rgData.Cells

' Если нужно суммировать по заливке:

If fBackBolor = True Then

' Включение ячейки в сумму в зависимости от цвета _

заливки и фильтра

If fAbsence Then

' Если ячейка имеет заданный цвет, то она не включается _

в вычисления

If cell.Interior.Color <> lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

Else

' Если ячейка имеет заданный цвет, то она включается _

в вычисления

If cell.Interior.Color = lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

End If

' В противном случае – суммируется по шрифту

Else

' Включение ячейки в сумму в зависимости _

от ее цвета и фильтра

If fAbsence Then

' Если ячейка имеет заданный цвет, то она не включается _

в вычисления

If cell.Font.Color <> lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

Else

' Если ячейка имеет заданный цвет, то она включается _

в вычисления

If cell.Font.Color = lngColor Then

intCount = intCount + 1

Values(intCount) = cell.Value

End If

End If

End If

Next cell

' Выполнение над собранными значениями операции, заданной

в intMode

For i = 1 To intCount

Select Case intMode

Case dhcSum, dhcAvg

' Подсчет суммы значений

varOut = varOut + Values(i)

Case dhcSumPlus

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

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

Case dhcSumMinus

' Посчет суммы отрицательных значений

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

Case dhcMax

' Нахождение максимального значения

If Values(i) > varOut Then varOut = Values(i)

Case dhcMin

' Нахождение минимального значения

If i = LBound(Values) Then varOut = Values(i)

If Values(i) < varOut Then varOut = Values(i)

Case dhcCount

' Подсчет количества значений

varOut = varOut + 1

Case dhcCountFull

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

If Not IsEmpty(Values(i)) Then varOut = varOut + 1

Case dhcCountNotNull

' Подсчет количества пустых ячеек

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