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

Листинг 2.59.Подсчет количества видимых ячеек

FunctiondhCountVisibleCells(rgRangeAsRange)

Dim lngCount As Long

Dim cell As Range

' Проходим по всему диапазону и подсчитываем непустые _

видимые ячейки

For Each cell In rgRange

' Проверка, есть ли данные в ячейке

If Not IsEmpty(cell) Then

' Проверка, видима ли ячейка

If Not cell.EntireRow.Hidden And Not _

cell.EntireColumn.Hidden Then

' Еще одна видимая ячейка

lngCount = lngCount + 1

End If

End If

Next cell

dhCountVisibleCells = lngCount

End Function

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

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

Function dhGetNextMonday(datDate As Date) As Date

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

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

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

IfWeekday(datDate,vbMonday) = 1Then

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

dhGetNextMonday=datDate

Else

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

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

EndIf

EndFunction

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

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

Function dhCalculateAge(datDate As Date) As Long

DimlngAgeAsLong

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

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

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

Day(datDate)) >DateThen

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

lngAge = lngAge - 1

End If

dhCalculateAge = lngAge

EndFunction

Проверка, была ли сохранена рабочая книга

Листинг 2.62. Функция dhBookIsSaved

Function dhBookIsSaved() As Boolean

' Если путь файла рабочей книги не задан, то она _

не сохранена (ThisWorkbook.path равняется "")

dhBookIsSaved = ThisWorkbook.path <> ""

End Function

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

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

FunctiondhAverageWithWeight(rgWeightsAsRange,rgValuesAsRange) _

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.65. Функция dhNSum

Function dhNSum(ByVal intCount As Integer, _

rgValues As Range) As Double

Dim i As Integer

Dim dblSum As Double

If intCount > rgValues.Count Then

' Задано количество элементов большее, чем есть _

в переданном диапазоне

intCount=rgValues.Count

EndIf

' Расчет суммы первых intCountэлементов

For i = 1 To intCount

dblSum = dblSum + rgValues(i)

Nexti

' Возврат результата

dhNSum=dblSum

EndFunction

Поиск последней непустой ячейки диапазона

Листинг 2.66. Функция dhLastUsedCell

Function dhLastUsedCell(rgRange As Range) As Long

Dim lngCell As Long

' Пойдем по диапазону с конца (тогда первая попавшаяся _

заполненная ячейка и будет искомой)

For lngCell = rgRange.Count To 1 Step -1

If Not IsEmpty(rgRange(lngCell)) Then

' Нашли непустую ячейку

dhLastUsedCell = lngCell

Exit Function

End If

Next lngCell

' Непустую ячейку не нашли

dhLastUsedCell = 0

End Function

Поиск последней непустой ячейки столбца

Листинг 2.67. Функция dhLastColUsedCell

Function dhLastColUsedCell(rgColumn As Range) As Variant

' Вывод значения последней непустой ячейки столбца

dhLastColUsedCell = rgColumn.Parent.Cells(Rows.Count, _

rgColumn.Column).End(xlUp).Value

End Function

Поиск последней непустой ячейки строки

Листинг 2.68.Функция dhLastRowUsedCell

Function dhLastRowUsedCell(rgRow As Range) As Variant

' Вывод значения последней непустой ячейки строки

dhLastRowUsedCell = rgRow.Parent.Cells(rgRow.Row, 256). _

End(xlToLeft).Address

End Function

Подсчет количества ячеек в диапазоне, содержащих указанные значения

Листинг 2.69. Функция dhCountSomeCells

Function dhCountSomeCells(rgRange As Range, dblMin As Double, _

dblMaxAsDouble)AsLong

' Расчет количества ячеек со значениями от dblMinдоdblMax_

с использованием стандартной функции CountIf

WithApplication.WorksheetFunction

dhCountSomeCells = .CountIf(rgRange, ">=" & dblMin) - _

.CountIf(rgRange, ">" & dblMax)

EndWith

EndFunction

Англоязычный текст — заглавными буквами

Листинг 2.70.Английский текст — в верхнем регистре

Function dhFormatEnglish(strText As String) As String

Dim i As Integer

Dim strCurChar As String * 1

' Анализируется каждый символ строки strText. Каждый символ _

латинского алфавита преобразуется в верхний регистр

For i = 1 To Len(strText)

strCurChar=Mid(strText,i, 1)

' Код латинских строчных символов лежит в пределах _

от 97 до 122

If Asc(strCurChar) >= 97 And Asc(strCurChar) <= 122 Then

' Переводим символ в верхний регистр

dhFormatEnglish=dhFormatEnglish&UCase(strCurChar)

Else

' Просто добавляем символ в выходную строку

dhFormatEnglish = dhFormatEnglish & strCurChar

End If

Next i

EndFunction