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

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

 

Применение функции без ввода ее в ячейку

Листинг 3.14. Применение функции без ввода в ячейку

Sub Func()

[A1] = Application.Sum([B5:B10])

End Sub

Подсчет именованных объектов

Листинг 3.29. Количество именованных объектов

Sub CountNames()

Dim intNamesCount As Integer

' Получаем и отображаем количество имен в активной _

рабочей книге

intNamesCount = ActiveWorkbook.Names.Count

If intNamesCount = 0 Then

MsgBox "Имен нет"

Else

MsgBox "Имен: " & intNamesCount & " шт."

End If

End Sub

 

Включение автофильтра с помощью макроса

Листинг 3.63. Включение автофильтра

Sub EnableAutoFilter()

On Error Resume Next

Selection.AutoFilter

End Sub

 

Создание бегущей строки

Листинг 3.76. Создание бегущей строки

Dim intSpacesLeft As Integer ' Количество пробелов в начале строки

Sub Start()

' Установка начального количества пробелов

intSpacesLeft = 10

' Первый вызов функции бегущей строки

MovingString

End Sub

 

Sub MovingString()

If intSpacesLeft >= 0 Then

' Отображение строки

Range("A1").Value = Space(intSpacesLeft) & "Привет!"

intSpacesLeft = intSpacesLeft - 1

' Указывем Excel, что данную процедуру нужно вызвать через _

  1 секунду

Application.OnTime Now + TimeValue("00:00:01"), "MovingString"

End If

End Sub

Создание бегущей картинки

Листинг 3.77. Бегущая картинка

Sub MovingImage()

Dim i As Integer

Dim image As Object

 

' Создание изображения (в ячейке "A1")

With Range("A1")

' Формирование значения в ячейке:

' текст

.Value = "Привет!"

' полужирный шрифт

.Font.Bold = True

' цвет

.Font.Color = RGB(233, 133, 229)

' размер шрифта

.Font.Size = 16

' угол наклона

.Orientation = 30

 

' Отображение текста полностью

.EntireColumn.AutoFit

' Копирование в буфер обмена

.Copy

 

' Создание самостоятельного изображения (на основе _

  скопированных в буфер обмена данных)

Set image = ActiveSheet.Pictures.Paste(Link:=False)

 

' Содержимое ячейки больше не нужно

.Clear

End With

 

' Задание начального положения изображения (левый верхний _

угол листа)

With image

.Top = 0

.Left = 0

End With

 

MsgBox "ПУСК!"

With image

' Перемещение изображения по диагонали

For i = 0 To 100

   .Top = i

   .Left = i

Next

' Удаление изображения

.Delete

End With

' Удаление ссылки на изображение

Set image = Nothing

End Sub

Вращающиеся автофигуры

Листинг 3.79. Вращение автофигур

Sub RotatingAutoShapes()

Static fRunning As Boolean

' Проверка, выполняется ли уже этот макрос

If fRunning Then

' При повторном запуске останавливаем все запущенные макросы

fRunning = False

End

End If

 ' Укажем, что макрос запущен

fRunning = True

 

Dim cell As Range             ' Рабочая ячейка

Dim intLeftBorder As Long     ' Левая граница ячейки

Dim intRightBorder As Long    ' Правая граница ячейки

Dim intTopBorder As Long           ' Верхняя граница ячейки

Dim intBottomBorder As Long   ' Нижняя граница ячейки

Dim alngVertSpeed(1 To 2) As Long ' Массивы со значениями

Dim alngHorzSpeed(1 To 2) As Long ' горизонтальной и вертикальной

                                 ' составляющих скоростей фигур

Dim ashShapes(1 To 2) As Shape ' Массив перемещаемых автофигур

Dim i As Integer

 

' Заполнение массива автофигур

Set ashShapes(1) = ActiveSheet.shapes(1)

Set ashShapes(2) = ActiveSheet.shapes(2)

 

' Заполнение массива скоростей:

' для первой фигуры

alngVertSpeed(1) = 3

alngHorzSpeed(1) = 3

' для второй фигуры

alngVertSpeed(2) = 4

alngHorzSpeed(2) = 4

 

' Получение границ рабочей ячейки

Set cell = Range("B2")

intLeftBorder = cell.Left

intRightBorder = cell.Left + cell.Width

intTopBorder = cell.Top

intBottomBorder = cell.Top + cell.Height

 

' Выполнение вращения и перемещения фигур

Do

' Изменение положения каждой автофигуры

For i = 1 To 2

    With ashShapes(i)

       ' Контроль достижения правой границы ячейки

       If.Left +.Width + alngHorzSpeed(i) > intRightBorder Then

          ' Корректировка положения

         .Left = intRightBorder -.Width

          ' Изменение направления горизонтальной скорости _

           на противоположное

          alngHorzSpeed(i) = -alngHorzSpeed(i)

       End If

       ' Контроль достижения левой границы ячейки

       If.Left + alngHorzSpeed(i) < intLeftBorder Then

          ' Корректировка положения

         .Left = intLeftBorder

          ' Изменение направления горизонтальной скорости _

           на противоположное

          alngHorzSpeed(i) = -alngHorzSpeed(i)

       End If

       ' Контроль достижения нижней границы ячейки

       If.Top +.Height + alngVertSpeed(i) > intBottomBorder Then

          ' Корректировка положения

         .Top = intBottomBorder -.Height

          ' Изменение направления вертикальной скорости _

           на противоположное

          alngVertSpeed(i) = -alngVertSpeed(i)

       End If

       ' Контроль достижения верхней границы ячейки

       If.Top + alngVertSpeed(i) < intTopBorder Then

          ' Корректировка положения

         .Top = intTopBorder

          ' Изменение направления вертикальной скорости _

           на противоположное

          alngVertSpeed(i) = -alngVertSpeed(i)

       End If

 

       ' Перемещение автофигуры

      .Left =.Left + alngHorzSpeed(i)

      .Top =.Top + alngVertSpeed(i)

       ' Вращение автофигуры (изменение направления вращения _

        происходит каждый раз при изменении направления _

        вертикального перемещения)

      .IncrementRotation alngVertSpeed(i)

 

       ' Даем Excel команду обработать пользовательский ввод

       DoEvents

    End With

Next

Loop

End Sub

Вызов таблицы цветов

Листинг 3.80. Отображение таблицы цветов

Sub ShowColorTable()

Dim intColor As Integer

 

' Формирование заголовка таблицы

Range("A1").Value = "Цвет"

Range("B1").Value = "Значение свойства ColorIndex"

 

' Вывод таблицы

Range("A2").Select

For intColor = 1 To 56

' Окрашиваем ячейку столбца "A" в текущий цвет

With ActiveCell.Interior

   .ColorIndex = intColor

   .Pattern = xlSolid

   .PatternColorIndex = xlAutomatic

End With

' В ячейку столбца "B" вносим индекс текущего цвета

ActiveCell.Offset(0, 1).Value = intColor

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

ActiveCell.Offset(1, 0).Activate

Next

 

' Покажем ячейку "A1" (начало таблицы)

Range("A1").Select

ActiveWindow.ScrollRow = 1

End Sub

Создание калькулятора

Листинг 3.81. Создание калькулятора

Sub SimpleCalculator()

Dim strExpr As String

' Ввод выражения

strExpr = InputBox("Что будем считать?")

' Подсчет и вывод результата

MsgBox strExpr & " = " & Application.Evaluate(strExpr)

End Sub