Главная страница
Навигация по странице:

  • Листинг 6.6.

  • Готовые макросы в VBA Excel (Миронов.) (z-lib.org). Запуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6


    Скачать 1.47 Mb.
    НазваниеЗапуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6
    Дата26.06.2022
    Размер1.47 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel (Миронов.) (z-lib.org).doc
    ТипДокументы
    #615298
    страница43 из 47
    1   ...   39   40   41   42   43   44   45   46   47

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


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

    1   ...   39   40   41   42   43   44   45   46   47


    написать администратору сайта