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

  • Листинг 5.6.

  • Листинг 5.7.

  • Листинг 5.8.

  • Листинг 5.9.

  • Листинг 5.10.

  • Готовые макросы в 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
    страница38 из 47
    1   ...   34   35   36   37   38   39   40   41   ...   47

    Построение и удаление диаграммы нажатием одной кнопки


    Листинг 5.6. Быстрое построение и удаление диаграммы

    Sub CreateChart()

    ' Создание диаграммы

    Charts.Add

    ' Параметры диаграммы

    ' Тип диаграммы

    ActiveChart.ChartType = xlLineMarkers

    ' Заголовок

    ActiveChart.SetSourceData Range("B1:E2"), xlRows

    ActiveChart.Location xlLocationAsObject, Name

    ' Остальные параметры

    With ActiveChart

    ' Заголовок

    .HasTitle = True

    .ChartTitle.Characters.Text = Name

    ' Заголовок оси категорий

    .Axes(xlCategory, xlPrimary).HasTitle = True

    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text _

    = Sheets(Name).Range("A1").Value

    ' Заголовок оси значений

    .Axes(xlValue, xlPrimary).HasTitle = True

    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text _

    = Sheets(Name).Range("A2").Value

    ' Отображение легенды

    .HasLegend = False

    .HasDataTable = True

    .DataTable.ShowLegendKey = True

    ' Настройка отображения сетки

    With .Axes(xlCategory)

    .HasMajorGridlines = True

    .HasMinorGridlines = False

    End With

    With .Axes(xlValue)

    .HasMajorGridlines = True

    .HasMinorGridlines = False

    End With

    End With

    End Sub

    Sub DeleteChart()

    ' Удаление диаграммы

    ActiveSheet.ChartObjects.Delete

    End Sub

    Вывод списка диаграмм в отдельном окне


    Листинг_5.7.'>Листинг 5.7. Внедренные диаграммы

    Sub ShowSheetCharts()

    Dim strMessage As String

    Dim i As Integer

    ' Формирование списка диаграмм

    For i = 1 To ActiveSheet.ChartObjects.Count

    strMessage = strMessage & ActiveSheet.ChartObjects(i).Name _

    & vbNewLine

    Next i

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

    MsgBox strMessage

    End Sub

    Листинг 5.8. Перечень рабочих листов, содержащих обычные диаграммы

    Sub ShowBookCharts()

    Dim crt As chart

    Dim strMessage As String

    ' Формирование списка диаграмм

    For Each crt In ActiveWorkbook.Charts

    strMessage = strMessage & crt.Name & vbNewLine

    Next

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

    MsgBox strMessage

    End Sub

    Применение случайной цветовой палитры


    Листинг 5.9. Случайная цветовая палитра

    Sub RandomChartColors()

    Dim intGradientStyle As Integer, intGradientVariant As Integer

    Dim i As Integer

    ' Проверка, выделена ли диаграмма

    If ActiveChart Is Nothing Then Exit Sub

    ' Изменение оформления всех категорий

    For i = 1 To ActiveChart.SeriesCollection.Count

    With ActiveChart.SeriesCollection(i)

    ' Вид градиентной заливки (случайный)

    intGradientStyle = Int(Rnd * 7) + 1

    If intGradientStyle = 6 Then intGradientStyle = 1

    If intGradientStyle = 7 Then

    intGradientVariant = Int(Rnd * 2) + 1

    Else

    intGradientVariant = Int(Rnd * 4) + 1

    End If

    ' Применение градиента

    .Fill.TwoColorGradient Style:=intGradientStyle, _

    Variant:=intGradientVariant

    ' Установка случайных цветов фона и обводки (используются _

    для градиента)

    .Fill.ForeColor.SchemeColor = Int(Rnd * 57) + 1

    .Fill.BackColor.SchemeColor = Int(Rnd * 57) + 1

    End With

    Next i

    End Sub

    Эффект прозрачности диаграммы


    Листинг 5.10. Эффект прозрачности диаграммы

    Sub TransparentChart()

    Dim shpShape As Shape

    Dim dblColor As Double

    Dim srSerie As Series

    Dim intBorderLineStyle As Integer

    Dim intBorderColorIndex As Integer

    Dim intBorderWeight As Integer

    ' Проверка, есть ли выделенная диаграмма

    If ActiveChart Is Nothing Then Exit Sub

    ' Изменение отображения каждой категории

    For Each srSerie In ActiveChart.SeriesCollection

    If (srSerie.ChartType = xlColumnClustered Or _

    srSerie.ChartType = xlColumnStacked Or _

    srSerie.ChartType = xlColumnStacked100 Or _

    srSerie.ChartType = xlBarClustered Or _

    srSerie.ChartType = xlBarStacked Or _

    srSerie.ChartType = xlBarStacked100) Then

    ' Сохранение прежнего цвета категории

    dblColor = srSerie.Interior.Color

    ' Сохранение стиля линий

    intBorderLineStyle = srSerie.Border.LineStyle

    ' Цвет границы

    intBorderColorIndex = srSerie.Border.ColorIndex

    ' Толщина линий границы

    intBorderWeight = srSerie.Border.Weight

    ' Создание автофигуры

    Set shpShape = ActiveSheet.shapes.AddShape _

    (msoShapeRectangle, 1, 1, 100, 100)

    With shpShape

    ' Закрашиваем нужным цветом

    .Fill.ForeColor.RGB = dblColor

    ' Делаем прозрачной

    .Fill.Transparency = 0.4

    ' Убираем линии

    .Line.Visible = msoFalse

    End With

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

    shpShape.CopyPicture Appearance:=xlScreen, _

    Format:=xlPicture

    ' Вставляем автофигуру в изображения столбцов _

    категории и настраиваем

    With srSerie

    ' Собственно вставка

    .Paste

    ' Возвращаем на место толщину линий

    .Border.Weight = intBorderWeight

    ' Стиль линий

    .Border.LineStyle = intBorderLineStyle

    ' Цвет границы

    .Border.ColorIndex = intBorderColorIndex

    End With

    ' Автофигура больше не нужна

    shpShape.Delete

    End If

    Next srSerie

    End Sub
    1   ...   34   35   36   37   38   39   40   41   ...   47


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