Excel. Трюки и эффекты

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