Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 23.01.2019
• Размер: 1.35 Mb.
• Имя файла: Готовые макросы в VBA Excel, Миронов.doc
• Тип: Документы; #64865
• страница: 44 из 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