Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Курилка
Страницы: 1
RSS
Красить линии на диаграммах в Power Point в разный цвет
 
#1
28.07.2015 11:29:02
Товарищи, подскажите пожалуйста может кто-то знает форум таких же любителей Power Point. Нужно автоматизировать одну веСЧь в презентации, я так полагаю с помощью макроса. Это к сожалению не мой конек, а красить 200 слайдов "кисточкой" не охота. Ну или если кто-то может помочь буду весьма благодарна.
 
 
 
#2
28.07.2015 11:31:55
В вое время искал такие форумы - не нашел... Но это года четыре назад было.
Пишите, что вам надо может подскажу... Был в свое время подобный опыт.
 
 
 
#3
28.07.2015 11:41:38
Давайте попробуем. Буду очень благодарна за помощь.
В Power Point есть обычные линейчатые диаграммы. Есть шкала цветов и значений, т.е. от 0-70 -бордовый цвет, 70-80 - красный, 80-85 - желтый и т.д. (в примере она есть). Линии в диаграммах нужно окрасить в соответствующий цвет в зависимости от их значения. Как в примере верхние 6.
Подозреваю что это можно сделать макросом, но вот как именно додуматься не могу.
 
 
 
#4
28.07.2015 12:31:50
Сделал макрос под Excel - красит все ряды на всех графиках активного листа в соответствии с условием.
Цвета подберите сами. Сейчас попробую под PowerPoint переделать - но не обещаю.
Код
    Sub ChartPointColor2()
     Dim myChartObject As ChartObject
        Dim mySeries As Series
        Dim myPts As Points
        Dim value As Double
        Dim x As Integer
     With ActiveSheet
            For Each myChartObject In .ChartObjects
                For Each mySeries In myChartObject.Chart.SeriesCollection
                    
                        For x = 1 To mySeries.Points.Count
                        
                            Select Case mySeries.Values(x)
                        
                        Case 0 To 69.9
                        mySeries.Points(x).Interior.Color = RGB(255, 0, 0)
                       
                       Case 70 To 79.99
                        mySeries.Points(x).Interior.Color = RGB(150, 0, 0)
                          
                          Case 80 To 84.99
                        mySeries.Points(x).Interior.Color = RGB(150, 150, 0)
                      
                          Case 90 To 94.99
                        mySeries.Points(x).Interior.Color = RGB(100, 100, 100)
                      
                         Case 95 To 100
                        mySeries.Points(x).Interior.Color = RGB(150, 1, 1)

                      Case Else
                        mySeries.Points(x).Interior.Color = RGB(255, 255, 255)
                        End Select
                        Next x                                     
                Next  
                Next
      
        End With
 End Sub    
 
 
 
#5
28.07.2015 13:26:15
Спасибо!
В Экселе действительно работает. Пробовала сделать связанную диаграмму. Тянуть данные из отдельной книги (ну а вдруг), не получилось.
Если получиться адаптировать под РР, будет супер!
Еще раз спасибо!
 
 
 
#6
28.07.2015 13:35:50
Скорее всего вечером смогу - у меня "древний код" на другом компьютере.
Не помню как в PowerPoint получить ChartObject - остальное все так же

p/s http://pharmaprofi.ru/article/21 - надстройка с помощью которой в 1 клик можно перекинуть диаграмму из excel в powerpoint
Изменено: pharmaprofi - 28.07.2015 13:37:52
 
 
 
#7
28.07.2015 21:54:28
Надстройка интересная, забрала себе. Спасибо!
А с адаптацией по PP не получилось? :cry:
 
 
 
#8
28.07.2015 23:47:29
К сожалению нет.
P.s. мне не удалось получить Chart со слайда. Примеры с MS почему то не работают...
 
 
 
#9
29.07.2015 00:16:42
Можно привязаться к подписям данных:
Код
Select Case CDbl(mySeries.Points(x).DataLabel.Caption)
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#10
29.07.2015 00:55:47
А вот и макросы:
Код
Option Explicit

Sub getColors()
    Dim pp As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Set pp = ActivePresentation
    Set sld = pp.Slides(2)
    
    For Each shp In sld.Shapes
        shp.Select
        Debug.Print shp.Fill.BackColor
        MsgBox shp.Fill.ForeColor
    Next shp
End Sub

Sub SeriesColoring()
    Dim sld As Slide
    Dim shp As Shape
    Dim cht As Chart
    Dim s As Series
    Dim x As Integer
    Dim i As Integer
    

    Set sld = ActivePresentation.Slides(1)
    For Each shp In sld.Shapes
        If shp.HasChart Then
            Set cht = shp.Chart
            For i = 1 To 3
            Set s = cht.SeriesCollection(i)
                For x = 1 To s.Points.Count
                    With s.Points(x).Interior
                        Select Case s.Values(x)

                        Case 0 To 69.9
                            .Color = 255    'RGB(255, 0, 0)

                        Case 70 To 79.99
                            .Color = 8420607    'RGB(150, 0, 0)

                        Case 80 To 84.99
                            .Color = 3407820    'RGB(150, 150, 0)

                        Case 90 To 94.99
                            .Color = 5296274    'RGB(100, 100, 100)

                        Case 95 To 100
                            .Color = 5296274    'RGB(150, 1, 1)

                        Case Else
                            .Color = 5287936    'RGB(255, 255, 255)
                        End Select
                    End With
                Next x
            Next i
        End If
    Next shp
End Sub

Первый макрос позволяет узнать цвета фигур (я скопировал из образцов слайда фигуру, разгруппировал, а потом нашел номера соответствующих цветов, которые уже указаны во втором макросе.
Писал ночью, поэтому ошибки возможны.
С уважением,
Федор/Все_просто
 
 
 
#11
29.07.2015 03:27:51
Ура! Спасибо огромное! Выручили, все работает.
С цветами разобралась, где нужно подкрутила :)
Последний вопрос.
Как указать перечень слайдов к которым макрос нужно применять?
Подозреваю в вот этой части  Set sld = ActivePresentation.Slides(1)
Но через запятую нельзя, нужно что-то типа where номер слайда inlist?
 
 
 
#12
29.07.2015 08:42:11
Чтобы сделать то же самое надо будет пройтись циклом по нужным слайдам, например вот так:
Код
for each sld in ActivePresentation.Slides.Range(Array(1, 3, 5, 7, 8))
     ваш код
next

В array(1,3,5,7,8) числа представляют номер слайда в презентации.
Изменено: Все_просто - 29.07.2015 08:42:23
С уважением,
Федор/Все_просто
 
 
 
#13
29.07.2015 12:14:05
Спасибо! Но что-то, я так подозреваю, я не туда всунула  :oops:
Ругается при запуске
Код
Sub SeriesColoring()
    Dim sld As Slide
    Dim shp As Shape
    Dim cht As Chart
    Dim s As Series
    Dim x As Integer
    Dim i As Integer
     
 
    Set sld = ActivePresentation.Slides
    For Each sld In ActivePresentation.Slides.Range(Array(12, 14, 17))
    For Each shp In sld.Shapes
        If shp.HasChart Then
            Set cht = shp.Chart
            For i = 1 To 3
            Set s = cht.SeriesCollection(i)
                For x = 1 To s.Points.Count
                    With s.Points(x).Interior
                        Select Case s.Values(x)
 
                        Case 0 To 69.9
                            .Color = 192    'RGB(255, 0, 0)
 
                        Case 70 To 79.99
                            .Color = 5066944   'RGB(150, 0, 0)
 
                        Case 80 To 84.99
                            .Color = 65535    'RGB(150, 150, 0)
                        
                        Case 85 To 89.99
                            .Color = 58032   'RGB(150, 150, 0)
 
                        Case 90 To 94.99
                            .Color = 5296274    'RGB(100, 100, 100)
 
                        Case 95 To 100
                            .Color = 5287936    'RGB(150, 1, 1)
 
                        Case Else
                            .Color = 1    'RGB(255, 255, 255)
                        End Select
                    End With
                Next x
            Next i
        End If
    Next shp
End Sub
 
 
 
#14
29.07.2015 12:29:19
Атлика, закомментируйте это:
Код
Set sld = ActivePresentation.Slides
и попробуйте запустить макрос.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#15
29.07.2015 14:49:46
Товарищи, простите, знаю что туплю нереально, но это практически мой первый опыт с макросами. Но не могу понять как это должно выглядеть в финале. Стыдно  :(
 
 
 
#16
29.07.2015 14:52:15
Атлика, я вижу лишнюю строку, указал Вам на неё. Пробовали её убрать или закомментировать (вначале строки поставить одинарную кавычку) и запустить макрос?

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#17
29.07.2015 15:16:57
Пробовала ругается.
Изменено: Атлика - 29.07.2015 15:17:15
 
 
 
#18
29.07.2015 15:35:33
Атлика, после:
Код
Next shp
вставьте строку с:
Код
Next sld

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#19
30.07.2015 10:00:05
В общем сработало только по 1 слайду. Но сработало.
Всем огромное спасибо за помощь!
Если кому-то интересно вот последняя версия кода:
Код
Sub SeriesColoring()
    Dim sld As Slide
    Dim shp As Shape
    Dim cht As Chart
    Dim s As Series
    Dim x As Integer
    Dim i As Integer
      
  
    Set sld = ActivePresentation.Slides(4)
    For Each shp In sld.Shapes
        If shp.HasChart Then
            Set cht = shp.Chart
            For i = 1 To 3
            Set s = cht.SeriesCollection(i)
                For x = 1 To s.Points.Count
                    With s.Points(x).Interior
                        Select Case s.Values(x)
  
                        Case 0 To 69.9
                            .Color = 192      'RGB(255, 0, 0)
  
                        Case 70 To 79.99
                            .Color = 5066944  'RGB(150, 0, 0)
  
                        Case 80 To 84.99
                            .Color = 65535    'RGB(150, 150, 0)
                         
                        Case 85 To 89.99
                            .Color = 58032    'RGB(150, 150, 0)
  
                        Case 90 To 94.99
                            .Color = 5296274  'RGB(100, 100, 100)
  
                        Case 95 To 100
                            .Color = 5287936  'RGB(150, 1, 1)
  
                        Case Else
                            .Color = 1        'RGB(255, 255, 255)
                        End Select
                    End With
                Next x
            Next i
        End If
    Next shp
End Sub
Еще раз всем огромное спасибо!
 
 
 
Страницы: 1
Наверх