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

  • Листинг 2.50.

  • Листинг 2.60.

  • Листинг 2.61.

  • Листинг 2.63.

  • Листинг 2.64.

  • Листинг 2.73.

  • Листинг 2.74.

  • Готовые макросы в 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
    страница44 из 47
    1   ...   39   40   41   42   43   44   45   46   47

    ГЛАВА .ДРУГИЕ ФУНКЦИИ И МАКРОСЫ

    Вызов функциональных клавиш


    Sub Test()

    SendKeys ("{F1}")

    End Sub

    Расчет среднего арифметического значения


    Sub CalculateAverage()

    Dim strFistCell As String

    Dim strLastCell As String

    Dim strFormula As String

    ' Условия закрытия процедуры

    If ActiveCell.Row = 1 Then Exit Sub

    ' Определение положения первой и последней ячеек для расчета

    strFistCell = ActiveCell.Offset(-1, 0).End(xlUp).Address

    strLastCell = ActiveCell.Offset(-1, 0).Address

    ' Формула для расчета среднего значения

    strFormula = "=AVERAGE(" & strFistCell & ":" & strLastCell & ")"

    ' Ввод формулы в текущую ячейку

    ActiveCell.Formula = strFormula

    End Sub

    Перевод чисел в «деньги»


    Листинг 2.50. Функция RubKop

    Function RubKop(Число)

    ' Пустые ячейки и ячейки, содержащие текст, функция _

    не обрабатывает

    If IsNumeric(Число) = False Or Число = "" Then RubKop = _

    "<>": Exit Function

    ' Из числа целой части - рубли

    ДлинаЧисла = Len(Число)

    ЦелаяЧасть = Fix(Число)

    ДлинаЦелой = Len(ЦелаяЧасть)

    ' Вычисление длины дробной части

    ДлинаДроби = ДлинаЧисла - ДлинаЦелой

    If ДлинаДроби <> 0 Then

    ДлинаДроби = ДлинаЧисла - ДлинаЦелой - 1

    End If

    ' Формирование количества копеек в зависимости от длины _

    дробной части

    If ДлинаДроби = 0 Then

    ' Ноль копеек

    Копейки = "00"

    ElseIf ДлинаДроби = 1 Then

    ' Дробная часть состоит из одного числа - это _

    десятки копеек

    Копейки = Right(Число, ДлинаДроби) & "0"

    ElseIf ДлинаДроби = 2 Then

    ' Дробная часть полностью соответствует количеству копеек

    Копейки = Right(Число, ДлинаДроби)

    Else

    ' Длина дробной части больше двух - округлим _

    дробную часть

    Копейки = Right(Число, ДлинаДроби)

    If Mid(Копейки, 3, 1) > 4 Then

    Копейки = Left(Копейки, 2) + 1

    Else

    Копейки = Left(Копейки, 2)

    End If

    End If

    ' Составление полной надписи из количества рублей и копеек

    Рубли = ЦелаяЧасть

    RubKop = Рубли & " " & "руб." & " " & Копейки & " " & "коп."

    End Function

    Поиск ближайшего понедельника


    Листинг_2.60.'>Листинг 2.60. Ближайший день недели по отношению к дате

    Function dhGetNextMonday(datDate As Date) As Date

    ' Определение даты следующего понедельника (функция Weekday _

    возвращает номер дня недели, считая от понедельника, если _

    в качестве второго аргумента задавать vbMonday)

    If Weekday(datDate, vbMonday) = 1 Then

    ' Заданная дата и есть понедельник

    dhGetNextMonday = datDate

    Else

    ' Расчет даты следующего понедельника

    dhGetNextMonday = datDate + 8 - Weekday(datDate, vbMonday)

    End If

    End Function

    Подсчет количества полных лет


    Листинг 2.61. Функция dhCalculateAge

    Function dhCalculateAge(datDate As Date) As Long

    Dim lngAge As Long

    ' Находим разность между текущей датой и указанной (лет)

    lngAge = DateDiff("yyyy", datDate, Date)

    If DateSerial(Year(datDate) + lngAge, Month(datDate), _

    Day(datDate)) > Date Then

    ' В этом году день рождения еще не наступил

    lngAge = lngAge - 1

    End If

    dhCalculateAge = lngAge

    End Function

    Расчет средневзвешенного значения


    Листинг__2.73.'>Листинг_2.63.'>Листинг 2.63. Расчет средневзвешенного значения

    Function dhAverageWithWeight(rgWeights As Range, rgValues As Range) _

    As Double

    If (rgWeights.Count <> rgValues.Count) Then

    ' Количество весов не соответствует количеству аргументов

    dhAverageWithWeight = 0

    Exit Function

    End If

    Dim i As Integer

    Dim dblSum As Double ' Сумма значений

    Dim dblSumWeight As Double ' Взвешенная сумма значений

    ' Вычисление...

    For i = 1 To rgWeights.Count

    ' Взвешенной суммы значений

    dblSumWeight = dblSumWeight + rgWeights(i) * rgValues(i)

    ' Суммы значений

    dblSum = dblSum + rgWeights(i)

    Next

    ' Возвращение средневзвешенного значения

    dhAverageWithWeight = dblSumWeight / dblSum

    End Function

    Преобразование номера месяца в его название


    Листинг 2.64. Название месяца

    Function dhMonthName(intMonth As Integer) As String

    ' Возвращение имени месяца по его номеру (intMonth _

    является номером элемента в массиве с названиями месяцев)

    dhMonthName = Choose(intMonth, "Январь", "Февраль", "Март", _

    "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", _

    "Октябрь", "Ноябрь", "Декабрь")

    End Function

    Использование относительных ссылок


    Листинг 2.73. Функция dhSheetOffset

    Function dhSheetOffset(offset As Integer, cell As Range) As Variant

    ' Возврат корректного значения ячейки cell листа, смещение _

    которого относительно текущего задано переменной offset

    dhSheetOffset = Sheets(Application.Caller.Parent.Index _

    + offset).Range(cell.Address)

    End Function

    Листинг 2.74. Функция dhSheetOffset2

    Function dhSheetOffset2(offset As Integer, cell As Range) As Variant

    ' Корректировка смещения (чтобы ссылка была на рабочий лист)

    Do While TypeName(Sheets(cell.Parent.Index + offset)) _

    <> "Worksheet"

    If offset > 0 Then

    ' Пропускаем лист и проходим вперед по книге

    offset = offset + 1

    Else

    ' Пропускаем лист и проходим назад по книге

    offset = offset - 1

    End If

    Loop

    ' Возврат корректного значения ячейки cell листа, смещение _

    которого относительно текущего задано переменной offset _

    с пропуском листов с диаграммами

    dhSheetOffset2 = Sheets(cell.Parent.Index _

    + offset).Range(cell.Address)

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


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