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