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

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

Преобразование таблицы Excel в html-формат

Листинг 3.60. Преобразование таблицы в HTML-формат

Sub ExportAsHtml()

Dim strStyle As String ' Параметры стиля отображения ячейки

Dim strAlign As String ' Параметры выравнивания ячейки

Dim strOut As String ' Выходная строка с HTML-кодом

Dim cell As Object ' Обрабатываемая ячейка

Dim strCellText As String ' Текст обрабатываемой ячейки

Dim lngRow As Long ' Номер строки обрабатываемой ячейки

Dim lngLastRow As Long ' Номер строки предыдущей ячейки

Dim strTemp As String

Dim objWordApp As Object

Dim i As Long

lngLastRow = Selection.Row

' Просмотр всех выделенных ячеек

For Each cell In Selection

' Значение строки для рассматриваемой ячейки

lngRow = cell.Row

' Если перешли на другую строку, то вставляем <tr>

If lngRow <> lngLastRow Then

strOut = strOut & vbTab & "</tr>" & vbCrLf & vbTab & _

"<tr>" & vbCrLf

' Переход на следующую строку

lngLastRow = lngRow

End If

' Задание шрифта ячейки

If Not IsNull(cell.Font.Size) Then

strStyle = " style=" & "font-size: " & Int(100 * _

cell.Font.Size / 19) & "%;"

End If

' Для полужирного шрифта вставляем <b>

If cell.Font.Bold Then

strCellText = "<b>" & strCellText & "</b>"

End If

' Задание выравнивания

If cell.HorizontalAlignment = xlRight Then

' По правому краю

strAlign = " align=" & "right"

ElseIf cell.HorizontalAlignment = xlCenter Then

' По центру

strAlign = " align=" & "center"

Else

' По левому краю (по умолчанию)

strAlign = ""

End If

' Чтение текста в ячейке

strCellText = cell.Text

' Если нужно, то вертикальный вывод текста (в строку strTemp _

с последующим перенесением обратно в strCellText)

If cell.Orientation <> xlHorizontal Then

strTemp = ""

' Печать после каждого символа специального _

разделителя - <br>

For i = 1 To Len(strCellText)

strTemp = strTemp & Mid$(strCellText, i, 1) & "<br>"

Next i

strCellText = strTemp

strStyle = ""

End If

strOut = strOut & vbTab & vbTab & "<td" & strStyle & strAlign _

& ">" & strCellText & "</td>" & vbCrLf

Next

' Вставка <tr> для первой строки и </tr> - для последней

strOut = vbTab & "<tr>" & vbCrLf & strOut & vbTab & "</tr>" & vbCrLf

' Вставка дескриптора <table>

strOut = "<table border=1 cellpadding=3 cellspacing=1>" & vbCrLf & _

strOut & vbCrLf & "</table>"

' Запускаем Word и показываем в нем сформированный HTML-код

Set objWordApp = CreateObject("Word.Application")

objWordApp.documents.Add

objWordApp.Selection = strOut

objWordApp.Selection.Copy

objWordApp.Visible = True

Set objWordApp = Nothing

End Sub