![]() Главная страница Случайная страница КАТЕГОРИИ: АвтомобилиАстрономияБиологияГеографияДом и садДругие языкиДругоеИнформатикаИсторияКультураЛитератураЛогикаМатематикаМедицинаМеталлургияМеханикаОбразованиеОхрана трудаПедагогикаПолитикаПравоПсихологияРелигияРиторикаСоциологияСпортСтроительствоТехнологияТуризмФизикаФилософияФинансыХимияЧерчениеЭкологияЭкономикаЭлектроника |
Расчет на основании ячеек определенного цвета⇐ ПредыдущаяСтр 30 из 30
Листинг 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
|