мм текущего рабочего листа, то можно воспользоваться следующим макросом (листинг 4.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
После выполнения данного макроса на экране отобразится окно с перечнем имен внедренных диаграмм активного рабочего листа.
Можно вывести список рабочих листов, содержащих обычные диаграммы (вынесенные на отдельный рабочий лист). Пример макроса, позволяющего решить эту задачу, приведен в листинге 4.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
После применения данного макроса появится окно с перечнем рабочих листов текущей книги, содержащих диаграммы.
Применение случайной цветовой палитры
Рассматриваемый в данном разделе трюк носит чисто эргономический характер. С его помощью можно при работе с внедренными диаграммами применять совершенно случайные цвета заливки элементов диаграммы.
Для получения эффекта случайной цветовой палитры можно использовать следующий макрос (листинг 4.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
Чтобы изменить цветовую палитру диаграммы, необходимо выделить ее и запустить данный макрос.
Эффект прозрачности диаграммы
С помощью несложного трюка можно сделать так, что диаграмма будет прозрачной. Для этого применим, например, такой макрос (листинг 4.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
После применения данного макроса диаграмма станет прозрачной. Степень прозрачности указывается в строке. Fill. Transparency = 0. 4 – в приведенном примере она равна 40 %. При необходимости данный параметр можно изменить по своему усмотрению. Например, на рис. 4.7 показана диаграмма, у которой прозрачность составляет 60 % (эта же диаграмма изображена на рис. 4.4 в непрозрачном виде).
Данный трюк применяется к созданным ранее диаграммам.
Рис. 4.7. Прозрачная диаграмма
Построение диаграммы на основе данных нескольких рабочих листов
В процессе работы нередко возникает необходимость в оперативной обработке данных, которые хранятся на нескольких рабочих листах. Как известно, одним из способов обработки информации является построение диаграмм. В этом разделе мы рассмотрим, каким образом можно построить одновременно несколько диаграмм, исходными данными для которых будет информация, расположенная на нескольких рабочих листах.
Предположим, что у нас имеются пять разных таблиц, которые расположены на пяти рабочих листах, причем количество строк в этих таблицах различается. Одна из таких таблиц показана на рис. 4.8.
Рис. 4.8. Пример таблицы
Для построения диаграмм на основании данных, хранящихся в этих таблицах, можно использовать макрос, код которого приведен в листинге 4.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
Перед запуском макроса нужно создать пустой рабочий лист для диаграмм. Макрос следует запускать, находясь на этом рабочем листе. В результате выполнения макроса будет создано сразу пять диаграмм, расположенных одна под другой, – по диаграмме для каждой таблицы. Диаграммам будут присвоены названия в соответствии со значением, хранящимся в ячейке А1 (например, на рис. 4.8 в данной ячейке хранится значение Таблица 4, поэтому и соответствующая ей диаграмма будет называться Таблица 4). Особо следует отметить, что приведенный макрос корректно обрабатывает данные в разных таблицах, несмотря на то что количество строк в них различается.