Расчет на основании ячеек определенного цвета

Листинг 6.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

Листинг 6.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, _

     "Внимание!"

    Cancel = True

    Exit Sub

End If

Next cell

Exit Sub

 

Err1:

' Обработка ошибок при работе с ячейками

If Err.Number = 1004 Then

MsgBox "Введите корректный адрес ячейки", vbCritical, _

  "Ошибка ввода"

Cancel = True

Exit Sub

Else

MsgBox Err.Description, vbCritical, "Ошибка ввода"

Cancel = True

Exit Sub

End If

End Sub

 

Sub txtResCell_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, _

     "Внимание!"

    Cancel = True

    Exit Sub

End If

Next cell

Exit Sub

 

Err1:

' Обработка ошибок при работе с ячейками

If Err.Number = 1004 Then

MsgBox "Введите корректный адрес ячейки", vbCritical, _

  "Ошибка ввода"

Cancel = True

Exit Sub

Else

MsgBox Err.Description, vbCritical, "Ошибка ввода"

Cancel = True

Exit Sub

End If

End Sub

 

Sub UserForm_Activate()

' Инициализация формы при активации

Dim intFunc As Integer

Dim strFunc As String

 

' Заполение списка доступных операций

cboCalcTypes.AddItem "0"

cboCalcTypes.List(0, 1) = "Сумма"

cboCalcTypes.AddItem "1"

cboCalcTypes.List(1, 1) = "Среднее"

cboCalcTypes.AddItem "2"

cboCalcTypes.List(2, 1) = "Максимум"

cboCalcTypes.AddItem "3"

cboCalcTypes.List(3, 1) = "Минимум"

cboCalcTypes.AddItem "4"

cboCalcTypes.List(4, 1) = "Количество ячеек"

cboCalcTypes.AddItem "5"

cboCalcTypes.List(5, 1) = "Сумма положительных"

cboCalcTypes.AddItem "6"

cboCalcTypes.List(6, 1) = "Сумма отрицательных"

cboCalcTypes.AddItem "7"

cboCalcTypes.List(7, 1) = "Количество непустых"

cboCalcTypes.AddItem "8"

cboCalcTypes.List(8, 1) = "Количество непустых ненулевых"

cboCalcTypes.AddItem "9"

cboCalcTypes.List(9, 1) = "Количество положительных"

cboCalcTypes.AddItem "10"

cboCalcTypes.List(10, 1) = "Количество отрицательных"

 

' Заполнение списка дополнительных цветов

cboOtherColor.AddItem "255"

cboOtherColor.List(0, 1) = "Красный"

cboOtherColor.AddItem "52479"

cboOtherColor.List(1, 1) = "Оранжевый"

cboOtherColor.AddItem "65535"

cboOtherColor.List(2, 1) = "Желтый"

cboOtherColor.AddItem "32768"

cboOtherColor.List(3, 1) = "Зеленый"

cboOtherColor.AddItem "16776960"

cboOtherColor.List(4, 1) = "Голубой"

cboOtherColor.AddItem "16711680"

cboOtherColor.List(5, 1) = "Синий"

cboOtherColor.AddItem "16711935"

cboOtherColor.List(6, 1) = "Фиолетовый"

cboOtherColor.AddItem "16777215"

cboOtherColor.List(7, 1) = "Белый"

cboOtherColor.AddItem "0"

cboOtherColor.List(8, 1) = "Черный"

 

If Selection.Cells.Count = 1 Then

' На листе есть выделенная ячейка. Определим, есть ли в этой _

  ячейке формула с функцией ColorCalc

intFunc = InStr(Selection.Formula, "ColorCalc(")

If intFunc > 0 Then

    ' Формула есть, заполним поля формы для вычислений

    ' Адрес ячейки с результатом

    txtResCell.Text = Selection.Address(False, False)

 

    ' Выделяем аргументы функции...

    ' Номера ячеек с исходными данными

    strFunc = Mid(Selection.Formula, intFunc + 11)

    intFunc = InStr(strFunc, """")

    txtRange.Text = Left(strFunc, intFunc - 1)

 

    ' Тип идентификации ячеек (по шрифту или цвету)

    strFunc = Mid(strFunc, intFunc + 2)

    intFunc = InStr(strFunc, ",")

    strFunc = Mid(strFunc, intFunc + 1)

    intFunc = InStr(strFunc, ",")

    tglType.Value = Left(strFunc, intFunc - 1)

 

    ' Режим вычислений

    strFunc = Mid(strFunc, intFunc + 1)

    strFunc = Left(strFunc, Len(strFunc) - 1)

    intFunc = InStr(strFunc, ",")

    cboCalcTypes.Text = cboCalcTypes.List(Val(Left$(_

     strFunc, intFunc - 1)), 1)

 

       strFunc = Mid(strFunc, intFunc + 1)

    chkVarify.SetFocus

    chkVarify.Value = CBool(strFunc)

    lblChoose.Visible = True

 

    GetColors

Else

    ' Будем применять формулу для выделенной ячейки

    txtRange.Value = Selection.Address(False, False)

    ' В выделенной ячейке конкретная функция не задана. _

     Выберем первую функцию в списке

    cboCalcTypes.Text = "Сумма"

End If

Else

' Будем применять формулу для выделенной ячейки

    txtRange.Value = Selection.Address(False, False)

' В выделенной ячейке конкретная функция не задана. _

  Выберем первую функцию в списке

cboCalcTypes.Text = "Сумма"

End If

End Sub

 

Sub GetColors()

' Отображение кнопок выбора цвета окрашенными в цвета, _

встречающиеся среди ячеек заданного диапазона

Dim rgCells As Range

Dim i As Integer

Dim intColorNumber As Integer ' Номер следующей кнопки _

                               выбора цвета

Dim lngCurColor As Long    ' Анализируемый цвет

Dim fColorPresented As Boolean ' Кнопка с цветом _

                               lngCurColor уже существует

Dim ctrl As Control

Dim strCtrl As String

Dim fBackColor As Boolean  ' = True, если ячейки _

                               идентифицируются по цвету фона, _

                               = False - по цвету шрифта

fBackColor = tglType.Value

 

On Error Resume Next

' Скрытие всех кнопок выбора цвета

For Each ctrl In Me.Controls

If Left(ctrl.Name, 8) = "cmbColor" Then

    ctrl.Visible = False

End If

Next ctrl

 

On Error GoTo ErrRange

Set rgCells = Range(txtRange.Text)

On Error GoTo 0

 

' Получение цвета первой ячейки

If fBackColor = False Then

  lngCurColor = rgCells.Cells(i).Font.Color

Else

lngCurColor = rgCells.Cells(i).Interior.Color

End If

' Назначения цвета первой ячейки первой кнопке

cmbColor1.BackColor = lngCurColor

cmbColor1.Visible = True

 

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

отображение кнопок, окрашенных в эти цвета

intColorNumber = 2

For i = 2 To rgCells.Cells.Count

fColorPresented = False

 

' Получение цвета i-й ячейки

If fBackColor = False Then

    lngCurColor = rgCells.Cells(i).Font.Color

Else

    lngCurColor = rgCells.Cells(i).Interior.Color

End If

 

' Проверка, отображается ли уже кнопка с таким цветом

For Each ctrl In Me.Controls

    If Left(ctrl.Name, 8) = "cmbColor" And _

     ctrl.Visible = True Then

       If lngCurColor = ctrl.BackColor Then

          ' Кнопка с цветом i-й ячейки уже отображается

          fColorPresented = True

          Exit For

       End If

    End If

Next ctrl

 

If Not fColorPresented Then

    ' Кнопки с цветом lngCurColor еще нет - покажем ее

    intColorNumber = intColorNumber + 1

    strCtrl = "cmbColor" & intColorNumber

    Me.Controls(strCtrl).BackColor = lngCurColor

    Me.Controls(strCtrl).Visible = True

End If

Next i

Exit Sub

 

ErrRange:

' Обработка ошибок при работе с диапазоном

If txtRange.Text = "" Then

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

  vbCritical, "Внимание!"

Else

  MsgBox "Введен некорректный адрес диапазона суммирования", _

  vbCritical, "Ошибка!"

End If

' Установка курсора в поле ввода диапазона

txtRange.SetFocus

End Sub

 

ГЛАВА.ДРУГИЕ ФУНКЦИИ И МАКРОСЫ

Вызов функциональных клавиш

Sub Test()

 SendKeys ("{F1}")

End Sub