Информатика. Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7

Название	Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7
Анкор	Информатика
Дата	16.05.2022
Размер	1.27 Mb.
Формат файла
Имя файла	VBA_v_primerakh.doc
Тип	Книга #532661
страница	11 из 21

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 ... 7 8 9 10 11 12 13 14 ... 21

Одновременное умножение всех данных диапазона

Листинг 3.59. Умножение данных

Sub MultAllCells()

Dim dblMult As Double

Dim cell As Range

' Ввод коэффициента для умножения

dblMult = InputBox("Введите коэффициент, на который следует умножать")

' Умножение содержимого на введенный коэффициент

For Each cell In Selection

If IsNumeric(cell.Value) And cell.Value <> "" Then

' Умножаются только ячейки, содержащие числовые данные

cell.Value = cell.Value * dblMult

Else

MsgBox "В ячейке " & cell.Address & " нечисловое значение"

End If

Next

End Sub

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

Листинг 3.61. Экспорт данных в HTM-файл

Sub ExportAsHtmlFile()

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 strFileName As String ' Имя файла для сохранения HTML-кода

Dim i As Long

' Запрос у пользователя имени файла для сохранения

strFileName = Application.GetSaveAsFilename( _

InitialFileName:="Primer.htm", _

fileFilter:="HTML Files(*.htm), *.htm")

' Проверка, задал ли пользователь имя файла (если нет, _

то можно выходить)

If strFileName = "" Then Exit Sub

lngLastRow = Selection.Row

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

For Each cell In Selection

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

lngRow = cell.Row

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