Создание программы
Итак, для создания программы нужно в модуле VBA написать код, который выполняет все расчеты, и создать форму, которая позволит сделать использование функции расчета более наглядным.
Программный код в стандартном модуле VBA выглядит следующим образом (листинг 5.5).
Листинг 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
В приведенном выше коде реализованы следующие элементы:
• функция ColorCalc – выполняет все расчеты с использованием цвета (параметры этой функции и ее аргументы рассматриваются в следующем разделе);
• макрос CalcColors – отображает форму управления расчетом (см. ниже).
В проект VBA необходимо также добавить форму и поместить в ее модуль код, приведенный в листинге 5.6.
Листинг 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, _
«Внимание!»
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
После помещения кода, представленного в листинге 5.6, в модуль формы необходимо сформировать ее внешний вид, как показано на рис. 5.10.
Рис. 5.10. Пользовательская форма
При работе с формой необходимо выполнить следующие действия (для присвоения значений свойствам используется панель VBA Properties (Свойства)):
• форме присвоить имя f rmColorCalc;
• двенадцати кнопкам (в правой верхней части формы) присвоить названия от cmbColorl до cmbColorl2;
• текстовому полю для указания диапазона суммирования присвоить следующее имя: txtRange;
• текстовому полю для указания адреса ячейки с результатом присвоить имя txtResCell;
• раскрывающемуся списку Другой присвоить имя cboOtherColor, а его свойству ColumnCount – значение 2;
• кнопке, расположенной справа от этого списка, присвоить имя cmbApplyColor;
• раскрывающемуся списку Тип вычислений присвоить имя cboCalcTypes, а его свойству ColumnCount – значение 2;
• флажку Проверять присвоить имя chkVarif у;
• элементу управления ToggleButton с надписью Шрифт присвоить имя tglType.
После произведенных действий можно легко заметить, что макросы в модуле формы – это обработчики событий соответствующих элементов управления.
Теперь создадим кнопку запуска программы на панели быстрого доступа, для чего выполним щелчок правой кнопкой мыши на этой панели и выберем команду контекстного меню Настройка панели быстрого доступа. В появившемся диалоговом окне (окно настройки Excel в режиме Настройка) в раскрывающемся списке Выбрать команды из выберем Макросы. При этом среди доступных команд дожна быть показана CalcColors, которую и нужно добавить на панель. На этом процесс создания программы можно считать завершенным.