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

  • If cell.Font.Bold ThenstrCellText = "" strCellText "

  • Листинг 2.77.

  • Листинг 2.78.

  • Готовые макросы в 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
    страница45 из 47


    If lngRow <> lngLastRow Then

    strOut = strOut & vbTab & "" & vbCrLf & vbTab & _

    "" & vbCrLf

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

    lngLastRow = lngRow

    End If

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

    If Not IsNull(cell.Font.Size) Then

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

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

    End If

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

    If cell.Font.Bold Then

    strCellText = "" & strCellText & ""

    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 = ""

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

    разделителя -


    For i = 1 To Len(strCellText)

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

    Next i

    strCellText = strTemp

    strStyle = ""

    End If

    strOut = strOut & vbTab & vbTab & "
    & ">" & strCellText & "" & vbCrLf

    Next

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

    strOut = vbTab & "
    " & vbCrLf & strOut & vbTab & "" & vbCrLf

    ' Вставка дескриптора
    1   ...   39   40   41   42   43   44   45   46   47

    Преобразование таблицы 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

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


    strOut = "
    " & vbCrLf & _

    strOut & vbCrLf & "
    "

    ' Запускаем 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.'>Листинг 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

    Случайные числа — на основании диапазона


    Листинг 2.78. Функция dhGetRandomValues1

    Function dhGetRandomValues1(rgSource As Range) As Variant

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

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

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

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

    Dim intValCount As Integer ' Количество возможных значений

    Dim cell As Range

    Dim i As Integer

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

    Application.Caller.Columns.Count)

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

    intValCount = rgSource.Rows.Count * rgSource.Columns.Count

    ReDim avarValues(1 To intValCount)

    ' Заполнение массива avarValues значениями из указанного _

    диапазона

    For Each cell In rgSource

    i = i + 1

    avarValues(i) = cell.Value

    Next cell

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

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

    Randomize

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

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

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

    i = Rnd * intValCount

    If i = 0 Then i = 1

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

    avarOut(intRow, intCol) = avarValues(i)

    Next intCol

    Next intRow

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

    dhGetRandomValues1 = avarOut

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


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