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

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

Генератор случайных чисел

Листинг 2.77. Функция dhGetRandomValues

Function dhGetRandomValues() As Variant

Dim intRow As Integer  ' Номер текущей строки

Dim intCol As Integer  ' Номер текущего столбца

Dim aintOut() As Integer ' Выходной массив (двумерный)

Dim aintValues() As Integer ' Массив с возможными значениями

Dim intMax As Integer  ' Последний доступный элемент массива _

                           aintValues

Dim i As Integer

 

ReDim aintOut(1 To Application.Caller.Rows.Count, 1 To _

Application.Caller.Columns.Count)

' Всего нужно чисел...

intMax = Application.Caller.Rows.Count * _

Application.Caller.Columns.Count

ReDim aintValues(1 To intMax)

' Заполнение массива aintValues значениями от 1 до intMax

For i = 1 To intMax

aintValues(i) = i

Next i

 

' Занесение значений в выходной массив aintOut, в произвольном _

порядке выбирая их из aintValues

Randomize

For intRow = 1 To Application.Caller.Rows.Count

For intCol = 1 To Application.Caller.Columns.Count

    ' Определение номера элемента из aintValues

    i = Rnd * intMax

    If i = 0 Then i = 1

    ' Занесение этого элемента в выходной массив

    aintOut(intRow, intCol) = aintValues(i)

 

    ' Уменьшение массива aintValues (то есть еще один его _

     элемент выбран) - замена выбранного элемента последним _

     в массиве

    aintValues(i) = aintValues(intMax)

       intMax = intMax - 1

Next intCol

Next intRow

' Возвращение массива значений

dhGetRandomValues = aintOut

End Function