с помощью VBA для пузырьковой диаграммы пироги в Excel

Question

Моего код

Sub PieMarkers() 

Dim chtMarker As Chart 
Dim chtMain As Chart 
Dim intPoint As Integer 
Dim rngRow As Range 
Dim lngPointIndex As Long 
Dim thmColor As Long 
Dim myTheme As String 


Application.ScreenUpdating = False 
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart 
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart 

Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart 
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo) 

For Each rngRow In Range("PieChartValues").Rows 
    chtMarker.SeriesCollection(1).Values = rngRow 
    ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme(thmColor) 
    chtMarker.Parent.CopyPicture xlScreen, xlPicture 
    lngPointIndex = lngPointIndex + 1 
    chtMain.SeriesCollection(1).Points(lngPointIndex).Paste 
    thmColor = thmColor + 1 
Next 

lngPointIndex = 0 

Application.ScreenUpdating = True 
End Sub 

Function GetColorScheme(i As Long) As String 
Const thmColor1 As String = "C:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\Blue Green.xml" 
Const thmColor2 As String = "C:\Program Files\Microsoft Office\Document Themes 14\Theme Colors\Orange Red.xml" 
    Select Case i 
     Case 0 
      GetColorScheme = thmColor1 
     Case 1 
      GetColorScheme = thmColor2 
    End Select 
End Function 

код предназначен для изменения цвета темы последовательных круговых диаграмм, которые используются в виде пузырьков в пузырьковой диаграмме. Таким образом, функция предназначена только для выбора цветовой схемы, которую я ранее сохранил в виде строки, а затем для ее изменения в соответствии с запуском скрипта, чтобы первый пирог имел другой цвет, чем следующая круговая диаграмма. Я получаю сообщение об ошибке при отладке кода на линии

ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme (thmColor)

сообщение об ошибке ошибка во время выполнения 2147024809 говоря указанное значение из range..can кто-нибудь помочь мне в чем проблема?

И будет ли какой-либо способ интегрировать отображение компонентов пироги (имя из componetns, которые Ši, указанные в верхней части колонны в каждой круговой диаграмме, который затем передается на пузырьковой диаграмму?

Answer 1

Самый простой путь - просто изменить цвета тем, прежде чем копировать каждый график.

Записанный макрос даст вам что-то вроде этого (для Excel 2010 в Windows 7), я выбираю только два, но вы можете использовать любое количество их, или вы также можете создавать свои собственные темы для использования:

ActiveWorkbook.Theme.ThemeColorScheme.Load (_ 
    "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Apex.xml" _ 
    ) 
ActiveWorkbook.Theme.ThemeColorScheme.Load (_ 
    "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Essential.xml" _ 
    ) 

Чтобы воспроизвести их, включите магнитофон, а затем выберите несколько цветовых схем из ленты (макет страницы | Цвета). Я думаю, что это должно работать для Excel 2007+, хотя путь к файлу будет отличаться для 2007 года, чем в моем примере.

Теперь, как применить это к коду ... Есть несколько способов сделать это. Я добавлю несколько строковых переменных Const, сохранив путь каждого из них, который мы будем использовать. Затем я добавлю индексную переменную и функцию, которая определит, какую тему использовать на основе индекса.

Вам нужно будет добавить дополнительные функции в функции для размещения не только двух цветных тем, но и ошибок.

Sub PieMarkers() 

Dim chtMarker As Chart 
Dim chtMain As Chart 
Dim intPoint As Integer 
Dim rngRow As Range 
Dim lngPointIndex As Long 
Dim thmColor as Long 
Dim myTheme as String 


Application.ScreenUpdating = False 
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart 
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart 

Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart 
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo) 

For Each rngRow In Range("PieChartValues").Rows 
    chtMarker.SeriesCollection(1).Values = rngRow 
    ThisWorkbook.Theme.ThemeColorScheme.Load GetColorScheme(thmColor) '## Call a function to get the color scheme location 
    chtMarker.Parent.CopyPicture xlScreen, xlPicture 
    lngPointIndex = lngPointIndex + 1 
    chtMain.SeriesCollection(1).Points(lngPointIndex).Paste 
    thmColor = thmColor + 1 '## Increment our index variable 
Next 

lngPointIndex = 0 

Application.ScreenUpdating = True 
End Sub 

Включите дополнительную функцию, GetColorScheme. В этой функции добавьте Const строковые переменные, такие как thmColor1 и thmColor2, и присвойте их значения путям файлов, которые вы создаете из макрорекордера при выборе цветовой темы. В этом примере я использую только два, но вы можете использовать многие из них, если вы добавите соответствующий Case в блок Select.

Function GetColorScheme(i as Long) as String '## Returns the path of a color scheme to load 
    '## Currently set up to ROTATE between only two color schemes. 
    ' You can add more, but you will also need to change the 
    ' Select Case i Mod 2, to i Mod n; where n = the number 
    ' of schemes you will rotate through. 
    Const thmColor1 as String = "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Apex.xml" 
    Const thmColor2 as String = "C:\Program Files (x86)\Microsoft Office\Document Themes 14\Theme Colors\Essential.xml" 


    Select Case i Mod 2 '## i Mod n; where n = the number of Color Schemes. 
     case 0 
      GetColorScheme = thmColor1 
     case 1 
      GetColorScheme = thmColor2 
     'Case n '## You should have an additional case for each 1 to n. 
     ' 
    End Select 
End Function