Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9
 Скачать 1.35 Mb.
|
Расчет на основании ячеек определенного цветаЛистинг 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 |