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

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

SubMultAllCells()

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& " нечисловое значение"

EndIf

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 ' Текст обрабатываемой ячейки

DimlngRowAsLong' Номер строки обрабатываемой ячейки

DimlngLastRowAsLong' Номер строки предыдущей ячейки

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

Листинг 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 ' Текст обрабатываемой ячейки

DimlngRowAsLong' Номер строки обрабатываемой ячейки

DimlngLastRowAsLong' Номер строки предыдущей ячейки

Dim strTemp As String

Dim strFileName As String ' Имя файла для сохранения HTML-кода

DimiAsLong

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

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

' Если перешли на другую строку, то вставляем <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>"

' Сохранение HTML-кода в файл

Open strFileName For Output As 1

Print #1, strOut

Close 1

' Вывод окна с информационным сообщением о результатах работы

MsgBox Selection.Count & " ячеек экспортировано в файл " & _

strFileName

End Sub