Второй способ

Листинг 2.26.Заполнение указанного диапазона

SubFillCellRect()

Dim lngRows As Long, intCols As Integer ' Количество ячеек по _

горизонтали и вертикали

Dim lngRow As Long, intCol As Integer ' Координаты текущей ячейки

Dim lngStep As Long, lngVal As Long

' Установка начального значения и шага заполнения

lngVal= 1

lngStep= 1

' Ввод количества ячеек по горизонтали и вертикали, которое _

необходимо заполнить

lngRows=Val(InputBox("Количество ячеек в высоту"))

intCols=Val(InputBox("Количество ячеек в ширину"))

' Отключение обновления экрана

Application.ScreenUpdating=False

' Заполнение ячеек значениями

ForlngRow= 1TolngRows

For intCol = 1 To intCols

ActiveCell.Offset(lngRow, intCol).Value = lngVal

lngVal = lngVal + lngStep

Next intCol

Next lngRow

' Включение обновления экрана

Application.ScreenUpdating = True

EndSub

Третий способ

Листинг 2.27.Заполнение диапазона

Sub FillCellRect1()

Dim lngRows As Long, intCols As Integer

Dim lngRow As Long, intCol As Integer

Dim lngStep As Long, lngVal As Long

Dim alngValues() As Long

Dim rgRange As Range

' Установка начального значения и шага заполнения

lngVal= 1

lngStep= 1

' Ввод количества ячеек по горизонтали и вертикали, которое _

необходимо заполнить

lngRows=Val(InputBox("Количество ячеек в высоту"))

intCols=Val(InputBox("Количество ячеек в ширину"))

ReDim alngValues(1 To lngRows, 1 To intCols)

Set rgRange = ActiveCell.Range(Cells(1, 1), _

Cells(lngRows, intCols))

' Заполнение массива alngValues значениями

For lngRow = 1 To lngRows

For intCol = 1 To intCols

alngValues(lngRow, intCol) = lngVal

lngVal = lngVal + lngStep

NextintCol

NextlngRow

' Перенос значений из массива в таблицу

rgRange.Value=alngValues

EndSub

Помещение в ячейку электронных часов

Листинг 2.28.Размещение в ячейке электронных часов

Sub UpdateTime()

Dim varNextCall As Variant

' Записываем в ячейку текущее время

Cells(1, 1).Value=Now

' Записываем в varNextCallвремя, когда вызвать этот макрос _

в следующий раз (через 1 секунду)

varNextCall = TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1)

' Уведомляем Excelв необходимости вызова макроса

Application.OnTime varNextCall, "UpdateTime"

End Sub

«Будильник»

Листинг 2.29.«Будильник»

SubClock()

' Уведомляем Excel, что процедуруAlarmнужно вызвать в 20:55

Application.OnTime TimeValue("20:55:00"), "Alarm"

End Sub

Sub Alarm()

MsgBox "Пора ужинать!!!"

EndSub

Поиск данных в диапазоне

Поиск в диапазоне значения по шаблону

Листинг 2.30.Поиск и замена по шаблону

Sub ReplaceCellsData()

Dim cell As Range

' Просмотр всех ячеек диапазона G1:K20 и замена искомого текста

For Each cell In [G1:K20]

If cell.Value Like "*Доход*" Then

cell.Value = "Выручка"

cell.Interior.Color = RGB(255, 255, 0)

Else

cell.Interior.Color = RGB(255, 255, 255)

EndIf

Next

EndSub

Поиск значения с выводом результата

Листинг 2.31.Поиск значения с отображением результата в отдельном окне

Sub Search()

Dim rgResult As Range

' Поиск заданного значения в диапазоне B1:B20 и вывод результата

Set rgResult = Range("B1:B20").Find(9999, , xlValues)

If rgResult Is Nothing Then

MsgBox "Поиск не дал результатов"

Else

MsgBox rgResult.Address

End If

End Sub

Поиск с выделением найденных данных

Листинг 2.32.Выделение найденных данных

SubFindAndSelect()

DimstrStartAddrAsString' Хранит координаты первого найденного _

значения

DimrgResultAsRange

' Поиск первого входжения искомого слова

Set rgResult = Range("B1:B10").Find("Прибыль", , xlValues)

If Not rgResult Is Nothing Then

' Сохраним адрес найденной ячейки (чтобы контролировать _

зацикливание поиска)

strStartAddr = rgResult.Address

End If

Do While Not rgResult Is Nothing

' Обработка результата поиска

rgResult.Interior.Color=RGB(255, 255, 0)

' Новый поиск

Set rgResult = Range("B1:B10").FindNext(rgResult)

If rgResult.Address = strStartAddr Then

' Поиск завершен

Exit Do

End If

Loop

End Sub