Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню FAQ | Макросы | Диаграмма & Графика


Rambler's Top100


Counter CO.KZ


    [1] [2]

  1. Как создать рабочую книгу с одним единственным листом диаграммы ? 09.03.2011
  2. Как программно заменить все диаграммы на их скриншоты(рисунки) ? 14.08.2011
  3. Как "разделить" круговую диаграмму и сохранить все составляющие в виде графических файлов ? NEW 14.07.2016
  4. Как изменить цвет всех точек диаграммы или как раскрасить точки случайными цветами ? 26.02.2011
  5. Как автоматически менять цвет точки диаграммы в зависимости от данных ячейки ? 27.02.2011
  6. Как автоматически менять цвет точки диаграммы в зависимости от цвета заливки ячейки ? NEW 10.08.2016
  7. Как в диаграмме заменить ссылки на ячейки значениями этих ячеек ? 27.02.2011
  8. Как изменить цвет минимальной и максимальной точки ? 07.03.2011
  9. Как найти точки с максимальными(минимальными) значениями и добавить им подпись, а при необходимости, и изменить цвет текста ? 30.12.2013
  10. Как с помощью VBA изменить тип диаграммы ? 07.03.2011
  11. Как программно отобразить диалоговое окно, позволяющее вручную изменить тип диаграммы ? 15.03.2011
  12. Как добавить существующую диаграмму в список нестандартных дополнительных диаграмм ? 18.03.2011
  13. Как определить над какой из точек диаграммы находится курсор мышки, причём без клика ? 27.03.2011
  14. Как автоматически выделить сектор круговой диаграммы, после наведения курсора мышки ? NEW 05.08.2016
  15. Как привести все диаграммы в рабочем листе к одинаковому размеру, т.е. установить одну высоту и ширину для всех диаграмм [без цикла] ? 20.02.2013
    [1] [2]


  • Ответ :
  • Workbooks.Add xlWBATChart
    Комментарий : После создания подобного листа необходимо ещё и построить саму диаграмму.

    Бонус : Следующий способ может оказаться полезен тем, кто работает с Visual Basic и предпочитает использовать позднее связывание, правда в этом случае, в нагрузку Вы получаете ещё и один рабочий лист, содержащий исходные данные для диаграммы.
    With CreateObject("Excel.Chart")
         'Здесь Вы можете работать с новым об'ектом (рабочая книга)
    End With
    Dim iObject As Object 'Workbook
    Set iObject = CreateObject("Excel.Chart")
    'iObject.Parent.Visible = True
    'Здесь Вы можете использовать об'ектную переменную

  • Ответ :

    Для того, чтобы в определённом рабочем листе, заменить все диаграммы на их скриншоты(рисунки), можно воспользоваться нижеопубликованным макросом :
  • Private Sub WSChartReplaceOnPicture()
        Dim iList As Worksheet
        Dim iChart As ChartObject
        Dim iCharts As ChartObjects
    
        Set iList = ThisWorkbook.Worksheets(1) 'укажите нужный рабочий лист
        Set iCharts = iList.ChartObjects
    
        Application.ScreenUpdating = False
    
        For iCount& = iCharts.Count To 1 Step -1
            Set iChart = iCharts(iCount&)
            iChart.Chart.CopyPicture _
            Appearance:=xlScreen, Format:=xlBitmap, Size:=xlScreen
            With iList.Pictures.Paste
                 .Top = iChart.Top
                 .Left = iChart.Left
                 '.Name = iChart.Name
                 .Name = Mid(iChart.Chart.Name, Len(iList.Name) + 2)
            End With
            'iChart.Delete
        Next
        iCharts.Delete
    
        Application.ScreenUpdating = True
    End Sub
    Private Sub WSChartReplaceOnPicture2()
        Dim iList As Worksheet
        Dim iChart As ChartObject
        Dim iCharts As ChartObjects
    
        Set iList = ThisWorkbook.Worksheets(1) 'укажите нужный рабочий лист
        Set iCharts = iList.ChartObjects
    
        Application.ScreenUpdating = False
    
        For iCount& = 1 To iCharts.Count
            Set iChart = iCharts(1)
            iChart.Chart.CopyPicture _
            Appearance:=xlScreen, Format:=xlBitmap, Size:=xlScreen
    
            With iList.Pictures.Paste
                 .Left = iChart.Left
                 .Top = iChart.Top
                 .Name = iChart.Name
                 '.Name = Mid(iChart.Chart.Name, Len(iList.Name) + 2)
            End With
            iChart.Delete
        Next
    
        Application.ScreenUpdating = True
    End Sub
    Private Sub WSChartReplaceOnPicture3()
        Dim iList As Worksheet
        Dim iChart As ChartObject
        Dim iCharts As ChartObjects
    
        Set iList = ThisWorkbook.Worksheets(1) 'укажите нужный рабочий лист
        Set iCharts = iList.ChartObjects
    
        'If iList.ProtectDrawingObjects = True Then
           'iList.Protect UserInterfaceOnly:=True 'Excel 97, 2000
           'iList.Protect _
            Password:="Ваш_пароль", UserInterfaceOnly:=True 'Excel XP
        'End If
    
        Application.ScreenUpdating = False
    
        If iCharts.Count > 1 Then
           For iCount& = iCharts.Count To 1 Step -1
               Set iChart = iCharts(iCount&)
               iChart.Chart.Export FileName:="C:\Temp.gif", FilterName:="GIF"
               With iList.Pictures.Insert(FileName:="C:\Temp.gif")
                    .Left = iChart.Left
                    .Top = iChart.Top
                    '.Name = iChart.Name
                    .Name = Mid(iChart.Chart.Name, Len(iList.Name) + 2)
               End With
           Next
           iCharts.Delete: Kill PathName:="C:\Temp.gif"
        End If
    
        Application.ScreenUpdating = True
    End Sub
    Комментарий : Обратите внимание на то, что если рабочий лист окажется защищён в отношении об'ектов, то в этом случае Вы получите ошибку, которой можно избежать, если воспользоваться следующим советом [FAQ42]

    Если же подобную замену нужно осуществить во всех незащищённых рабочих листах, а заодно и составить перечень(список) листов, где замена не была произведена, то используйте следующий макрос, естественно, не забыв указать нужную рабочую книгу.
    Private Sub WBChartReplaceOnPicture()
        Dim iCount&, iExcluded$
        Dim iList   As Worksheet
        Dim iChart  As ChartObject
        Dim iCharts As ChartObjects
        
        Application.ScreenUpdating = False
    
        For Each iList In ThisWorkbook.Worksheets
            If Not iList.ProtectDrawingObjects Then
               Set iCharts = iList.ChartObjects
               For iCount = iCharts.Count To 1 Step -1
                   Set iChart = iCharts(iCount)
                   iChart.Chart.CopyPicture xlScreen, xlBitmap, xlScreen
                   With iList.Pictures.Paste
                        .Left = iChart.Left
                        .Top = iChart.Top
                        .Name = iChart.Name 'iChart.Chart.Name
                        '.Name = Mid(iChart.Chart.Name, Len(iList.Name) + 2)
                   End With
                   'iChart.Delete
               Next
               iCharts.Delete
            Else
               iExcluded = iExcluded & vbCrLf & iList.Name
            End If
        Next
    
        Application.ScreenUpdating = True
    
        If iExcluded <> "" Then _
        MsgBox "Замена не произошла :" & iExcluded, vbCritical, ""
    End Sub

  • Ответ : Актуально для MS Excel 2000(и старше)

    Для того, чтобы в определённом рабочем листе, найти все круговые и разрезанные круговые диаграммы и сохранить все их составляющие в виде графических файлов, можно воспользоваться нижеопубликованным макросом. A после того, как временная рабочая книга, будет сохранена в виде HTML файла, Вы сможете увидеть все графические файлы в папке "C:\Temp_files"
  • Private Sub SavePieChartToPictures()
        Dim iList1 As Worksheet, iList2 As Worksheet
        Dim iCharts As ChartObjects, iChart As Chart
        Dim iGroup As Picture, iOffset&, iCount%
        
        Const iFileName = "C:\Temp.html" 'укажите временный файл
        
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
    
        Set iList1 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        Set iList2 = ThisWorkbook.Worksheets(1) 'укажите нужный рабочий лист
        Set iCharts = iList2.ChartObjects
        
        For iCount = 1 To iCharts.Count
            Set iChart = iCharts(iCount).Chart
            Select Case iChart.ChartType
                Case xlPie, xlPieExploded
                   iChart.CopyPicture Size:=xlScreen
                   Set iGroup = iList1.Pictures.Paste
                   ShapeList iGroup.ShapeRange.Ungroup, iOffset
            End Select
        Next
       
        With iList1.Parent
             .SaveAs FileName:=iFileName, FileFormat:=xlHtml
             .FollowHyperlink Address:=Replace(iFileName, ".html", ".files")
             .Close saveChanges:=False
        End With
    
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub
    
    Private Sub ShapeList(iGroup As ShapeRange, iOffset&)
        Dim iShape As Shape
        For Each iShape In iGroup
            If iShape.Type = msoGroup Then
               ShapeList iShape.Ungroup, iOffset
            Else
               iShape.Top = iOffset
               iOffset = iOffset + iShape.Height + 10
            End If
        Next
    End Sub
    Комментарий : Если Вы являетесь обладателем Microsoft Excel 2007 и при программной попытке разгруппировать рисунок, получаете ошибку 1004, то это означает, что Вам необходимо установить соответствующий Service Pack.

    Issues that are fixed in the 2007 Microsoft Office suites Service Pack 1
  • Ответ :

    Для того, чтобы раскрасить все точки определённой диаграммы случайными цветами можно использовать нижеопубликованный макрос, только не забудьте указать нужную диаграмму (в первом макросе предполагается, что диаграмма расположена в отдельном листе Диаграммы, а во втором, что диаграмма находится на рабочем листе с кодовым именем Лист1) :
  • Private Sub ChartPointsRandColor()
        Dim iSerie As Series, iPoint As Point: Randomize 'Timer
        Application.ScreenUpdating = False
        For Each iSerie In Charts(1).SeriesCollection
            For Each iPoint In iSerie.Points
                iPoint.Interior.Color = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
            Next
        Next
        Application.ScreenUpdating = True
    End Sub
    Private Sub ChartObjectPointsRandColor()
        Application.ScreenUpdating = False
        Dim iSerie As Series, iPoint As Point: Randomize 'Timer
        For Each iSerie In Лист1.ChartObjects(1).Chart.SeriesCollection
            For Each iPoint In iSerie.Points
                iPoint.Interior.Color = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
            Next
        Next
        Application.ScreenUpdating = True
    End Sub

  • Ответ : Скачать пример Актуально для MS Excel 97, 2000, XP

    Если Вам необходимо автоматически менять цвет заливки точки, в зависимости от данных исходной ячейки, например, после ввода числа > 1000 окрасить точку в зелёный цвет, а после ввода числа < 100 в красный, то для этого можно воспользоваться событием рабочего листа Worksheet_Change, которое необходимо разместить в модуле рабочего листа (см. пример)
  • Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        Dim iSource As Range
        Set iSource = [B2:B6] 'Me.Range("B2:B6")
        If Not Intersect(Target, iSource) Is Nothing Then
           With Me.ChartObjects(1).Chart.SeriesCollection(1).Points
                For iCount% = 1 To .Count
                    Select Case iSource(iCount%)
                        Case 0 To 100: iColor& = vbRed
                        Case 100 To 200: iColor& = vbYellow
                        Case 200 To 500: iColor& = vbCyan
                        Case 500 To 1000: iColor& = vbMagenta
                        Case Is > 1000: iColor& = vbGreen
                    End Select
                    .Item(iCount%).Interior.Color = iColor&
                Next
           End With
        End If
    End Sub
    В этом примере используется диаграмма с одним рядом, построенная на основании данных диапазона [B2:B6]. Если диаграмма должна находиться в отдельном листе Диаграммы, или в другом рабочем листе, то в таком случае - Вам придётся заменить ключевое слово Me ссылкой на нужный лист. Кроме того, в данном примере допускается применение функции RGB, вместо используемых констант, например, RGB(50, 0, 100)
  • Ответ : Скачать пример Актуально для MS Excel 97-2003

    Если необходимо, чтобы сразу после изменения цвета заливки ячейки, цвет точки автоматически стал идентичным, то разместите весь нижеопубликованный код в модуле того рабочего листа, где находится диаграмма. И не забудьте указать свой индекс(номер) или имя диаграммы.
  • Private WithEvents ChartObject As Excel.Chart
    
    Private Sub ChartObject_Calculate() 'Excel 2000 (lite version)
        Dim iSeries As Series, iCell As Range
    
        For Each iSeries In ChartObject.SeriesCollection
            iFormula$ = iSeries.Formula
            iAddress$ = Split(iFormula$, ",")(2)
            For Each iCell In Application.Range(iAddress$)
                iCount% = iCount% + 1
                iSeries.Points(iCount%).Interior.Color = iCell.Interior.Color
            Next: iCount% = 0
        Next
    End Sub
    
    Private Sub Worksheet_Activate()
        Set ChartObject = Me.ChartObjects(1).Chart
        'Set ChartObject = Me.ChartObjects("Chart 1").Chart
        'Укажите существующей индекс(номер) или имя нужной диаграммы
    End Sub
    Если необходимо немного усложнить задачу и в случае, когда исходная ячейка не имеет заливки, необходимо будет вернуть у точки обычную заливку, то тогда :
    Private WithEvents ChartObject As Excel.Chart
    
    Private Sub ChartObject_Calculate() 'Excel 2000
        Dim iSeries As Series, iCell As Range
    
        For Each iSeries In ChartObject.SeriesCollection
            iFormula$ = iSeries.Formula
            iAddress$ = Split(iFormula$, ",")(2)
            For Each iCell In Application.Range(iAddress$)
                iCount% = iCount% + 1
                iColor% = iCell.Interior.ColorIndex
                If iColor% > xlNone Then
                   iSeries.Points(iCount%).Interior.ColorIndex = iColor%
                Else
                   iSeries.Points(iCount%).Interior.ColorIndex = xlAutomatic
                End If
            Next: iCount% = 0
        Next
    End Sub
    
    Private Sub Worksheet_Activate()
        Set ChartObject = Me.ChartObjects(1).Chart
        'Set ChartObject = Me.ChartObjects("Chart 1").Chart
        'Укажите существующей индекс(номер) или имя нужной диаграммы
    End Sub
    Примечание : Разумеется, в обоих примерах, синхронизация цвета будет происходить, только после выполнения события рабочего листа Worksheet_Activate. Если же активация листа Вас, по каким-то причинам, не устраивает, то вместо него можно использовать событие рабочей книги Worksheet_Open (вкупе с соответствующими изменениями)

    Комментарий : Если имя листа - источника данных, содержит запятую и/или диаграмма построена на основании данных несмежных ячеек, то вышеопубликованный парсинг формулы не позволит получить адрес ячеек.
  • Ответ :

    Не секрет, что после создания диаграммы можно разорвать связь этой диаграммы с исходными ячейками, для этого достаточно последовательно выделять каждый ряд и нажимать клавиши F2, F9 и ENTER. Если тоже самое необходимо проделать, но уже с помощью VBA, то в случае, если диаграмма расположена на рабочем листе с кодовым именем Лист1, можно использовать следующий макрос :
  • Private Sub ChartReplaceFormulasOnValues()
        Dim iChart As Chart, iSerie As Series
        Set iChart = Лист1.ChartObjects(1).Chart
        For Each iSerie In iChart.SeriesCollection
            iSerie.Name = iSerie.Name
            iSerie.Values = iSerie.Values
            iSerie.XValues = iSerie.XValues
        Next
    End Sub
    Eсли диаграмма расположена в отдельном листе с кодовым именем Диаграмма1 , то в таком случае можно использовать тот же макрос :
    Private Sub ChartReplaceFormulasOnValues2()
        Dim iSerie As Series
        For Each iSerie In Диаграмма1.SeriesCollection
            With iSerie
                 .Name = .Name
                 .Values = .Values
                 .XValues = .XValues
            End With
        Next
    End Sub
    Примечание : Допускается замена кодового(программного) имени рабочего листа и листа диаграммы, так, к примеру, вместо Лист1 можно использовать Worksheets(Индекс_листа), Worksheets("Имя_листа") , а вместо Диаграмма1 возможно применение Charts(Индекс_листа) или Charts("Имя_листа") , Sheets("Имя_листа")

    Комментарий : К сожалению, программный способ замены приведёт к возникновению ошибки, если в результате замены, формула =РЯД() теоретически будет содержать более 481 символов (не считая длины имени ряда)
    А вот замена вручную, при этом же количестве символов, возможна, правда если их количество всё же превысит стандартное ограничение формулы в 1024 символов, то Вы получите сообщение типа, Слишком сложная формула.

    Вариант II. (Microsoft Excel 2000 или старше)
    Private Sub ChartReplaceFormulasOnValues3()
        Dim iChart As Chart, iSerie As Series
        Set iChart = Лист1.ChartObjects(1).Chart
        For Each iSerie In iChart.SeriesCollection
            iCount& = iCount& + 1
            iFormula$ = "=SERIES(""" & iSerie.Name & """,{""" & _
            Join(iSerie.XValues, """;""") & """},{" & _
            Join(iSerie.Values, ";") & "}," & iCount& & ")"
            iSerie.Formula = iFormula$
        Next
    End Sub
    Private Sub ChartReplaceFormulasOnValues4()
        Dim iChart As Chart, iSeries As SeriesCollection
        Set iChart = Лист1.ChartObjects(1).Chart
        Set iSeries = iChart.SeriesCollection
        For iCount& = 1 To iSeries.Count
            With iSeries(iCount&)
                 .Formula = "=SERIES(""" & .Name & """,{""" & _
                 Join(.XValues, """;""") & """},{" & _
                 Join(.Values, ";") & "}," & iCount& & ")"
            End With
        Next
    End Sub
    Комментарий : Второй способ также приведёт к возникновению ошибки, если формула = iFormula$ будет содержать более 255 символов.

    Microsoft Excel 2007
    В этой версии, разработчики несколько увеличили лимит на количество символов в формуле (второй вариант). Однако, высчитывать их количество, сейчас нет особого смысла, т.к. есть альтернатива - первый вариант, где разработчики, возможно, "сняли" ограничение. Во всяком случае, мне удалось заменить ссылку на диапазон, где количество символов превышало 10000 шт.
  • Ответ :

    Если в уже существующей диаграмме Вам необходимо изменить цвет заливки у точки с минимальным и максимальным значением, то в случае, когда диаграмма расположена на рабочем листе с кодовым именем Лист1, и каждый ряд(серия) содержит только один минимум и максимум, Вы можете использовать следующий макрос :
  • Private Sub ChartSetColorMinMaxPoint()
        Dim iChart As Chart, iSerie As Series ', iValues As Variant
        Set iChart = Лист1.ChartObjects(1).Chart
        For Each iSerie In iChart.SeriesCollection
            iValues = iSerie.Values
            iMin# = Application.Min(iValues)
            iMax# = Application.Max(iValues)
            iPosMin& = Application.Match(iMin#, iValues, 0)
            iPosMax& = Application.Match(iMax#, iValues, 0)
            iSerie.Points(iPosMin&).Interior.Color = vbRed
            iSerie.Points(iPosMax&).Interior.Color = vbGreen
        Next
    End Sub
    Private Sub ChartSetColorMinMaxPoint1()
        Dim iSerie As Series, iValues As Variant
        For Each iSerie In Лист1.ChartObjects(1).Chart.SeriesCollection
            iValues = iSerie.Values
            iSerie.Points(Application.Match( _
            Application.Min(iValues), iValues, 0)).Interior.ColorIndex = 3
            iSerie.Points(Application.Match( _
            Application.Max(iValues), iValues, 0)).Interior.ColorIndex = 4
        Next
    End Sub
    Если ряд(серия) может содержать несколько точек с мин/макс, то в таком случае достаточно просто добавить перебор точек, т.е. использовать следующий вариант.
    Private Sub ChartSetColorMinMaxPoint2()
        Dim iChart As Chart, iSerie As Series, iPoint As Point
        Set iChart = Worksheets(1).ChartObjects(1).Chart
        For Each iSerie In iChart.SeriesCollection
            iValues = iSerie.Values
            iMin# = Application.Min(iValues)
            iMax# = Application.Max(iValues)
            For Each iPoint In iSerie.Points
                iCount& = iCount& + 1
                Select Case iValues(iCount&)
                    Case iMin#: iPoint.Interior.Color = vbRed
                    Case iMax#: iPoint.Interior.Color = vbGreen
                End Select
            Next
        Next
    End Sub
    Private Sub ChartSetColorMinMaxPoint2v2()
        Dim iChart As Chart, iSerie As Series, iPoints As Points
        Set iChart = Worksheets(1).ChartObjects(1).Chart
        For Each iSerie In iChart.SeriesCollection
            iValues = iSerie.Values
            iMin# = Application.Min(iValues)
            iMax# = Application.Max(iValues)
            Set iPoints = iSerie.Points  '''
            For iCount& = 1 To iPoints.Count
                Select Case iValues(iCount&)
                    Case iMin#
                    iPoints(iCount&).Interior.ColorIndex = 3
                    Case iMax#
                    iPoints(iCount&).Interior.ColorIndex = 10
                End Select
            Next
        Next
    End Sub
    Комментарий : Важно, чтобы выбранный цвет заливки (в данных примерах это красный и зелёный) не совпадал с изначальной заливкой точек, в противном случае, Вы получите диаграмму, где нужным цветом будут выделены не только точки с минимумом/максимумом. Впрочем, подобного совпадения цветов можно избежать, если предварительно установить цвет заливки у всех точек ряда, отличный от красного и зелёного, или же проверять цвет каждой точки и в случае совпадения, менять его. Кроме того, возможен вариант, при котором минимальное значение либо вообще не будет отображаться (к примеру, нулевое значение), либо визуально точка будет практически незаметна.
  • Ответ :

    Если в уже существующей диаграмме Вам необходимо найти, например, пять точек с максимальными значениями и добавить им подпись и/или изменить цвет текста подписи, то в случае, когда диаграмма расположена на рабочем листе с кодовым именем Лист1, Вы можете использовать следующий макрос :
  • Private Sub ChartShowLabel_5MaxValues()
        Dim iChart As Chart, iSerie As Series, iPoint As Point
        
        Set iChart = Лист1.ChartObjects(1).Chart
        Set iSerie = iChart.SeriesCollection(1)
        
        iSerie.HasDataLabels = False
        
        iValues = iSerie.Values
        iMax5# = Application.Large(iValues, Array(1, 2, 3, 4, 5))(5)
        'iArrMax = Application.Large(iValues, Array(1, 2, 3, 4, 5)): iMax5# = iArrMax(5)
        
        For iCount& = 1 To UBound(iValues)
            If iValues(iCount&) >= iMax5# Then
               Set iPoint = iSerie.Points(iCount&)           
               
               iPoint.ApplyDataLabels xlDataLabelsShowLabel
               iPoint.DataLabel.Font.ColorIndex = 3
               'iPoint.DataLabel.Font.Color = vbRed
            End If
        Next
    End Sub
    Комментарий : Если предполагается установить единый цвет текста для всех максимальных точек, то лучше не менять цвет шрифта в цикле, а установить его сразу для всей серии (см.пример)
  • Ответ : Скачать пример

    Для того, чтобы изменить тип диаграммы можно воспользоваться свойством ChartType, обратите внимание на то, что первый пример предназначен для диаграммы, которая размещена в отдельном листе, а второй, для диаграммы, которая находится на рабочем листе.
  • Charts(1).ChartType = xlLineMarkersStacked
    Worksheets(1).ChartObjects(1).Chart.ChartType = xlBarStacked100

  • Ответ :
  • ActiveWorkbook.Charts(1).Select '.Activate
    Application.Dialogs(xlDialogChartType).Show
    Worksheets(1).ChartObjects(1).Select '.Activate
    Application.Dialogs(xlDialogChartType).Show
    При желании, также как и в прошлых примерах, здесь можно использовать кодовое имя, например :
    Диаграмма1.Activate '.Select
    Application.Dialogs(xlDialogChartType).Show
    Лист1.ChartObjects(1).Activate '.Select
    Application.Dialogs(xlDialogChartType).Show
    Если необходимо "отловить" нажатие кнопок Отмена или Закрыть [X]
    If Application.Dialogs(xlDialogChartType).Show = True Then
       MsgBox "Вы изменили тип выделенной диаграммы"
    Else
       MsgBox "Вы отказались от своих замыслов"
    End If

  • Ответ :

    Если Вам необходимо программно добавить существующую нестандартную диаграмму - в список пользовательских типов диаграмм, то для этого можно использовать нижеопубликованный вариант, где третий именованный аргумент Description является необязательным, т.е. если краткое описание графика, для Вас, не представляет интереса, то этот аргумент можно оставить в покое. Обратите внимание на то, что первые два примера предназначены для диаграммы, которая размещена в отдельном листе, а следующие, для диаграммы, которая находится на рабочем листе.
  • Application.AddChartAutoFormat Chart:=Charts(1), Name:="BossChart", Description:="График для шефа"
    Application.AddChartAutoFormat Chart:=Диаграмма1, Name:="Мой_график", Description:="Дополнительная диаграмма"
    Application.AddChartAutoFormat Chart:=Worksheets(1).ChartObjects(1).Chart, Name:="DirectorChart", Description:="График для директора"
    Application.AddChartAutoFormat Chart:=Лист1.ChartObjects(1).Chart, Name:="1C", Description:="Выгрузка 1C"
    А если возникнет надобность в программном удаление такой диаграммы, то тогда используйте метод DeleteChartAutoFormat об'екта Application, только не забудьте правильно указать имя удаляемой диаграммы, иначе возникнет ошибка.
    Application.DeleteChartAutoFormat Name:="BossChart"

  • Ответ : Скачать пример Скачать пример

    Если Вам необходимо определить над какой из точек находится курсор мышки, причём не прибегая к выделению этой точки, то в таком случае можно использовать следующее событие диаграммы. Обратите внимание на то, что вывод информации в статус баре не носит обязательного характера и применяется только в качестве примера.
  • Private iElementID&, iSeriesIndex&, iPointIndex&

    Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
        Me.GetChartElement X, Y, iElementID, iSeriesIndex, iPointIndex
        If iElementID = xlSeries Then
           Application.StatusBar = "Ряд " & _
           iSeriesIndex & ": Точка " & iPointIndex
        Else
           Application.StatusBar = "Об'ект не найден"
        End If
    End Sub

    Private Sub Chart_Deactivate()
        Application.StatusBar = False
    End Sub
    Примечание : В данном примере предполагается, что диаграмма расположена в отдельном листе, а весь вышеприведённый код находится в модуле этой диаграммы.

    Если же речь идёт о диаграмме, которая находится в рабочем листе, то здесь также возможно применение события Chart_MouseMove, но только в случае, если диаграмма активна(выделена). В противном случае, указанное событие выполняться не будет, однако, это ограничение можно обойти, если пойти на маленькую хитрость, а именно :
    создать ActiveX элемент управления Надпись (Label) и используя свойства созданного элемента управления :
    - удалить текст, который отображается напротив поля Caption
    - напротив поля BackStyle выбрать 0 - fmBackStyleTransparent
    - и главное, расположить и изменить его размеры, так, чтобы подогнать надпись под месторасположение и размеры нужной диаграммы.
    После чего, использовать аналогичное событие, но уже не диаграммы, а созданного элемента управления, естественно, учитывая их особенности. Готовый пример, где демонстрируется этот трюк, можно скачать здесь.
  • Ответ :

    Если Вам необходимо привести все диаграммы в рабочем листе к одинаковому размеру, т.е. установить одну и туже высоту и ширину для всех диаграмм листа, причём осуществить это необходимо (или желательно) без цикла, то Вы можете воспользоваться нижеприведённым вариантом, разумеется, указав свою высоту(height) и ширину(width) и, при необходимости, заменив ActiveSheet на конкретный рабочий лист.
  • With ActiveSheet.ChartObjects.ShapeRange
         .Height = 100
         .Width = 100
    End With
    Комментарий : Обратите внимание, что в случае отсутствия диаграмм на рабочем листе, Вы получите ошибку, которую можно избежать, если просто добавить проверку, например If ActiveSheet.ChartObjects.Count > 0


    Вопросы - Синонимы
  • Как с помощью VBA разорвать связь между диаграммой и ячейками рабочего листа ? 27.02.2011


  • Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Excel 95, 97, 2000, XP

    © 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff