Готовые макросы в VBA Excel, Миронов. Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 23.01.2019
• Размер: 1.35 Mb.
• Имя файла: Готовые макросы в VBA Excel, Миронов.doc
• Тип: Документы; #64865
• страница: 46 из 47

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

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