Главная страница
Навигация по странице:

  • Листинг 5.11.

  • Листинг 5.12.

  • Готовые макросы в VBA Excel (Миронов.) (z-lib.org). Запуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6


    Скачать 1.47 Mb.
    НазваниеЗапуск макроса с поиском ячейки 6 Запуск макроса при открытии книги 6
    Дата26.06.2022
    Размер1.47 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel (Миронов.) (z-lib.org).doc
    ТипДокументы
    #615298
    страница39 из 47
    1   ...   35   36   37   38   39   40   41   42   ...   47

    Построение диаграммы на основе данных нескольких рабочих листов


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

    Создание подписей к данным диаграммы


    Листинг 5.12. Подписи к данным диаграммы

    Sub ShowLabels()

    Dim rgLabels As Range ' Диапазон с подписями

    Dim chrChart As Chart ' Диаграмма

    Dim intPoint As Integer ' Точка, для которой добавляется подпись

    ' Определение диаграммы

    Set chrChart = ActiveSheet.ChartObjects(1).Chart

    ' Запрос на ввод диапазона с исходными данными

    On Error Resume Next

    Set rgLabels = Application.InputBox _

    (prompt:="Укажите диапазон с подписями", Type:=8)

    If rgLabels Is Nothing Then Exit Sub

    On Error GoTo 0

    ' Добавление подписей

    chrChart.SeriesCollection(1).ApplyDataLabels _

    Type:=xlDataLabelsShowValue, _

    AutoText:=True, _

    LegendKey:=False

    ' Просмотр диапазона и назначение подписей

    For intPoint = 1 To chrChart.SeriesCollection(1).Points.Count

    chrChart.SeriesCollection(1). _

    Points(intPoint).DataLabel.Text = rgLabels(intPoint)

    Next intPoint

    End Sub

    Sub DeleteLabels()

    ' Удаление подписей диаграммы

    ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1). _

    HasDataLabels = False

    End Sub
    1   ...   35   36   37   38   39   40   41   42   ...   47


    написать администратору сайта