КАТЕГОРИИ: Архитектура-(3434)Астрономия-(809)Биология-(7483)Биотехнологии-(1457)Военное дело-(14632)Высокие технологии-(1363)География-(913)Геология-(1438)Государство-(451)Демография-(1065)Дом-(47672)Журналистика и СМИ-(912)Изобретательство-(14524)Иностранные языки-(4268)Информатика-(17799)Искусство-(1338)История-(13644)Компьютеры-(11121)Косметика-(55)Кулинария-(373)Культура-(8427)Лингвистика-(374)Литература-(1642)Маркетинг-(23702)Математика-(16968)Машиностроение-(1700)Медицина-(12668)Менеджмент-(24684)Механика-(15423)Науковедение-(506)Образование-(11852)Охрана труда-(3308)Педагогика-(5571)Полиграфия-(1312)Политика-(7869)Право-(5454)Приборостроение-(1369)Программирование-(2801)Производство-(97182)Промышленность-(8706)Психология-(18388)Религия-(3217)Связь-(10668)Сельское хозяйство-(299)Социология-(6455)Спорт-(42831)Строительство-(4793)Торговля-(5050)Транспорт-(2929)Туризм-(1568)Физика-(3942)Философия-(17015)Финансы-(26596)Химия-(22929)Экология-(12095)Экономика-(9961)Электроника-(8441)Электротехника-(4623)Энергетика-(12629)Юриспруденция-(1492)Ядерная техника-(1748) |
Расчет на основании ячеек определенного цвета
Листинг 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
Дата добавления: 2015-06-25; Просмотров: 346; Нарушение авторских прав?; Мы поможем в написании вашей работы! Нам важно ваше мнение! Был ли полезен опубликованный материал? Да | Нет |