Информатика. Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7

• Название: Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7
• Анкор: Информатика
• Дата: 16.05.2022
• Размер: 1.27 Mb.
• Имя файла: VBA_v_primerakh.doc
• Тип: Книга; #532661
• страница: 18 из 21

Глава 5. Эксперименты с диаграммами

Построение диаграммы с помощью макроса

Листинг 5.1. Макрос построения диаграммы

Sub CreateChart()

' Создание и настройка диаграммы

With Charts.Add

' Данные из первого листа

.SetSourceData Source:=Worksheets(1).Range("A1:E4")

' Заголовок

.HasTitle = True

.ChartTitle.Text = "Выручка по магазинам"

' Активизируем диаграмму

.Activate

End With

End Sub

Листинг 5.2. Построение внедренной диаграммы

Sub CreateEmbeddedChart()

' Создание и настройка внедренной диаграммы

With Worksheets(1).ChartObjects.Add(100, 60, 250, 200)

' Объемная диаграмма

.Chart.ChartType = xl3DArea

' Источник данных

.Chart.SetSourceData Source:=Worksheets(1).Range("A1:E4")

End With

End Sub

Листинг 5.3. Создание диаграммы на основе выделенных данных

Sub CreateCharOnSelection()

' Создание диаграммы (с заданием положения на листе)

With ActiveSheet.ChartObjects.Add( _

Selection.Left + Selection.Width, _

Selection.Top + Selection.Height, 300, 200).Chart

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

.ChartType = xlColumnClustered

' Источник данных - выделение

.SetSourceData Source:=Selection, PlotBy:=xlColumns

' Без легенды

.HasLegend = False

' Без заголовка

.HasTitle = True

.ChartTitle.Characters.Text = "Выручка за период"

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

.Parent.Select

End With

End Sub

Сохранение диаграммы в отдельном файле

Листинг 5.4. Сохранение диаграммы

Sub SaveChart()

' Сохранение выделенной диаграммы в файл

If ActiveChart Is Nothing Then

' Нет выделенных диаграмм

MsgBox "Выделите диаграмму"

Else

' Сохранение...

ActiveChart.Export ActiveWorkbook.path & "\Диаграмма.gif", "GIF"

End If

End Sub

Листинг 5.5. Сохранение диаграммы под указанным именем

Sub InteractiveSaveChart()

Dim strFileName As String ' Имя файла для сохранения

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

If ActiveChart Is Nothing Then

' Нет выделенных диаграмм

MsgBox "Выделите диаграмму"

Else

' Выбор файла для сохранения

strFileName = Application.GetSaveAsFilename( _

ActiveChart.Name & ".gif", "Файлы GIF (*.gif), *.gif", 1, _

"Сохранить диаграмму в формате GIF")

' Проверка, выбран ли файл

If strFileName <> "" Then

' Сохранение выделенной диаграммы в файл

ActiveChart.Export strFileName, "GIF"

End If

End If

End Sub

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

Листинг 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. Внедренные диаграммы

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

Построение диаграммы на основе данных нескольких рабочих листов

Листинг 5.11. Одновременное создание нескольких диаграмм

Sub ManyCharts()

Dim intTop As Long, intLeft As Long

Dim intHeight As Long, intWidth As Long

Dim sheet As Worksheet

Dim lngFirstRow As Long ' Первая строка с данными

Dim intSerie As Integer ' Текущая категория диаграммы

Dim strErrorSheets As String ' Список листов, для которых _

не удалось построить диаграммы

intTop = 1 ' Верхняя точка первой диаграммы

intLeft = 1 ' Левая точка каждой диаграммы

intHeight = 180 ' Высота каждой диаграммы

intWidth = 300 ' Ширина каждой диаграммы

' Постоение диаграммы для каждого листа, кроме текущего

For Each sheet In ActiveWorkbook.Worksheets

If sheet.Name <> ActiveSheet.Name Then

' Первый заполненный ряд

lngFirstRow = 3

' Первая категория

intSerie = 1

On Error GoTo DiagrammError

' Добавление и настройка диаграммы

With ActiveSheet.ChartObjects.Add _

(intLeft, intTop, intWidth, intHeight).Chart

Do Until IsEmpty(sheet.Cells(lngFirstRow + intSerie, 1))

' Создание ряда

.SeriesCollection.NewSeries

' Значения для ряда

.SeriesCollection(intSerie).Values = _

sheet.Range(sheet.Cells(lngFirstRow + intSerie, 2), _

sheet.Cells(lngFirstRow + intSerie, 4))

' Диапазон данных для подписей

.SeriesCollection(intSerie).XValues = _

sheet.Range("B3:D3")

' Название ряда (берется из столбца "A" таблицы с данными)

.SeriesCollection(intSerie).Name = sheet.Cells( _

lngFirstRow + intSerie, 1)

intSerie = intSerie + 1

Loop

' Настройка внешнего вида диаграммы

.ChartType = xl3DColumnClustered

.ChartGroups(1).GapWidth = 20

.PlotArea.Interior.ColorIndex = xlNone

.ChartArea.Font.Size = 9

' Диаграмма с легендой

.HasLegend = True

' Заголовок

.HasTitle = True

.ChartTitle.Characters.Text = sheet.Range("A1")

' Задание диапазона значений на осях

.Axes(xlValue).MinimumScale = 0

.Axes(xlValue).MaximumScale = 120000

' Стиль линий сетки (прерывистый)

.Axes(xlValue).MajorGridlines.Border. _

LineStyle = xlDot

End With

On Error GoTo 0

' Сдвиг верхней точки следующей диаграммы на высоту _

текущей диаграммы

intTop = intTop + intHeight

AfterError:

End If

Next sheet

If strErrorSheets <> "" Then

' Отобразим список листов, для которых не построили диаграммы

MsgBox "Не удалось построить диаграммы для листов:" & Chr(13) _

& strErrorSheets, vbExclamation

End If

Exit Sub

DiagrammError:

' Добавление в список имени листа, для которого не смогли _

построить диаграмму (ошибка в данных для диаграммы)

strErrorSheets = strErrorSheets & sheet.Name & Chr(13)

' Удаление пустой диаграммы на текущем листе

ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Delete

' Продолжаем работу с другими листами

Resume AfterError

End Sub

Создание подписей к данным диаграммы

Листинг 5.12. Подписи к данным диаграммы

Sub ShowLabels()

Dim rgLabels As Range ' Диапазон с подписями

Dim chrChart As Chart ' Диаграмма

Dim intPoint As Integer ' Точка, для которой добавляется подпись

' Определение диаграммы

Set chrChart = ActiveSheet.ChartObjects(1).Chart

' Запрос на ввод диапазона с исходными данными

On Error Resume Next

Set rgLabels = Application.InputBox _

(prompt:="Укажите диапазон с подписями", Type:=8)

If rgLabels Is Nothing Then Exit Sub

On Error GoTo 0

' Добавление подписей

chrChart.SeriesCollection(1).ApplyDataLabels _

Type:=xlDataLabelsShowValue, _

AutoText:=True, _

LegendKey:=False

' Просмотр диапазона и назначение подписей

For intPoint = 1 To chrChart.SeriesCollection(1).Points.Count

chrChart.SeriesCollection(1). _

Points(intPoint).DataLabel.Text = rgLabels(intPoint)

Next intPoint

End Sub

Sub DeleteLabels()

' Удаление подписей диаграммы

ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1). _

HasDataLabels = False

End Sub