![]() Главная страница Случайная страница КАТЕГОРИИ: АвтомобилиАстрономияБиологияГеографияДом и садДругие языкиДругоеИнформатикаИсторияКультураЛитератураЛогикаМатематикаМедицинаМеталлургияМеханикаОбразованиеОхрана трудаПедагогикаПолитикаПравоПсихологияРелигияРиторикаСоциологияСпортСтроительствоТехнологияТуризмФизикаФилософияФинансыХимияЧерчениеЭкологияЭкономикаЭлектроника |
Построение диаграммы на основе данных нескольких рабочих листов
Листинг 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
|