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). Особо следует отметить, что приведенный макрос корректно обрабатывает данные в разных таблицах, несмотря на то что количество строк в них различается.
