Главная страница
Навигация по странице:

  • Листинг 3.14.

  • Листинг 3.63.

  • Листинг 3.77.

  • Листинг 3.79.

  • Готовые макросы в VBA Excel (Миронов.) (z-lib.org). Запуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6


    Скачать 1.47 Mb.
    НазваниеЗапуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6
    Дата26.06.2022
    Размер1.47 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel (Миронов.) (z-lib.org).doc
    ТипДокументы
    #615298
    страница46 из 47
    1   ...   39   40   41   42   43   44   45   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
    1   ...   39   40   41   42   43   44   45   46   47


    написать администратору сайта