Решила выложить макрос не в опыте, а в теме, т.к. построение диаграммы делалось под определенные исходные данные, и внешний вид диаграммы соответствует конкретным запросам пользователя. Если данные в Excel поменяются, то диаграмма не изменится.
Возможно, специалисты по макросам найдут к чему придраться.
2-ой раз столкнулась с необходимостью писать макрос и убедилась, что «запись макроса» очень многое не воспроизводит. В моем случае она практически ничего не дала. На написание макроса по построению диаграммы было потрачено намного больше времени, чем на формирование самих данных и вывод их в Excel.
Для меня так и остался не решенным вопрос: почему при попытке сформировать в макросе подписи для оси ОХ, когда для этого использовать дискретный диапазон ячеек, у меня была ошибка, хотя при ручном формировании диаграммы дискретный диапазон брался без проблем. После долгих мучений пошла на хитрость: эти же данные для подписи вывела дополнительно (помимо шапки таблицы) в другом месте непрерывным диапазоном и для этих ячеек установила белый цвет шрифта.
Код: Выделить всё
Attribute VB_Name = "ImportedModule"
Public Sub ColorForSerGradient(ByVal NomSer As Integer, ByVal NomPoint As Integer, ByVal Red1 As Integer, ByVal Green1 As Integer, ByVal Blue1 As Integer )
'
' ColorForSerGradient
' Установка для указанного ряда и точки градинта указанного цвета в RGB
With ActiveChart.SeriesCollection(NomSer).Format.Fill
If NomPoint<3 Then
.GradientStops(NomPoint).Position = NomPoint - 1
.GradientStops(NomPoint).Color = RGB(Red1, Green1, Blue1)
Else
.GradientStops.Insert RGB(Red1, Green1, Blue1), 0.5 ' добавление 3-ей точки градиента
End If
End With
End Sub
Sub MakeChartOnPodr( nomD As Integer, NamePodr As String, rowFrom As Integer, rowTo As Integer, MaxY As Integer )
'
' MakeChartOnPodr Макрос
' Построение диаграммы.
' Параметры: номер даграммы по порядку, наименование подразделения, строка С и строка ПО с данными для диаграммы,
' мах значение по оси ОУ (мах з/п)
Dim DataRange As Range
Dim ChtObj As ChartObject
Dim mySeries As Series
Dim seriesCol As SeriesCollection
Dim LastRow As Long
Dim i As Integer
Dim nomRow As Integer
Dim nameD As String, sDiag As String
Dim sRowB As String, sRowE As String
Dim HeigthOfChars As Long, HeigthOfData As Long
' переводим число в строку
sRowB = Format( rowFrom)
sRowE = Format(rowTo)
' наименование объекта
sDiag = "Диаграмма" & Str(nomD)
' наименование диаграммы
nameD = "Диаграмма" & NamePodr
' диапазон данных для построения диаграммы
' Set DataRange = Range( _
' "E5:E7,G5:G7,I5:I7,K5:K7,M5:M7,O5:O7,Q5:Q7,S5:S7,U5:U7,W5:W7,Y5:Y7,AA5:AA7")
Set DataRange = Range( _
"E" & sRowB & ":E" & sRowE _
& ", G" & sRowB & ":G" & sRowE _
& ", I" & sRowB & ":I" & sRowE _
& ", K" & sRowB & ":K" & sRowE _
& ", M" & sRowB & ":M" & sRowE _
& ", O" & sRowB & ":O" & sRowE _
& ", Q" & sRowB & ":Q" & sRowE _
& ", S" & sRowB & ":S" & sRowE _
& ", U" & sRowB & ":U" & sRowE _
& ", W" & sRowB & ":W" & sRowE _
& ", Y" & sRowB & ":Y" & sRowE _
& ", AA" & sRowB & ":AA" & sRowE )
' Последняя заполненная строка с данными
LastRow = ActiveSheet.Cells( ActiveSheet.Rows.Count, "A").End(xlUp).Row + 1
' общая высота всех предыдущих диаграмм по вертикали
HeigthOfChars = (nomD - 1)*200
' Эта ячейка, с которой будем строить 1-ую диаграмму
Cells( LastRow + 3 , 1).Select
' Высота данных с таблицей
HeigthOfData = ActiveCell.Top
' Высота ячеек с таблицей с учетом предыдущих диаграмм
HeigthOfData = HeigthOfData + HeigthOfChars
' добавить диаграмму на текущий лист, указан верхний левый угол диаграммы и ее размер
Set ChtObj = ActiveSheet.ChartObjects.Add _
(ActiveCell.Left, HeigthOfData, 1200, 200)
With ChtObj.Chart
' установить тип диаграммы – гистограмма с группировкой
.ChartType = xlColumnClustered
' задать диапазон данных (диапазоны ячеек с з/п по месяцам периода)
' .SetSourceData Source:=DataRange, PlotBy:=xlColumns
.SetSourceData Source:=DataRange, PlotBy:=xlRows
' имеет легенду
.HasLegend = True
' легенда располагается слева
.Legend.Position = xlLeft
' имеет заголовок
.HasTitle = True
' задать заголовок диаграммы
.ChartTitle.Characters.Text = "Выплата на руки по месяцам, $ ( " & NamePodr & ") , сравнительный анализ"
' заголовок диаграммы поместить над диаграммой
.SetElement (msoElementChartTitleAboveChart)
' установки вывода наименования осей
' .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis)
' задать наименование для оси категорий ОХ
' .Axes(xlCategory, xlPrimary).AxisTitle.Text = "Периоды"
' будем выводимть наименование вертикальной оси ОУ.
' .SetElement (msoElementPrimaryValueAxisTitleVertical)
' задать наименование для оси значений ОУ
' .Axes(xlValue, xlPrimary).AxisTitle.Text = "з/п"
' установки вывода наименования оси ОУ перевернуто
' .SetElement (msoElementPrimaryValueAxisTitleRotated)
.Axes(xlValue, xlPrimary).MaximumScale = MaxY
.Axes(xlValue, xlPrimary).MinimumScale = 0
.Axes(xlValue, xlPrimary).MajorUnit = 1000
' .Axes(xlValue, xlPrimary).MinorUnit = 250
' показывать пустые как нули
.DisplayBlanksAs = xlZero
.PlotVisibleOnly = False
.Parent.Select
End With
' установить указанной диаграмме имя
ActiveSheet.Shapes(sDiag).Name = nameD
'двухцветная градиентная заливка области диаграммы
With ActiveChart.ChartArea.Format.Fill
.Visible = msoTrue
.TwoColorGradient msoGradientHorizontal, 1
.ForeColor.RGB = RGB(195, 214, 155)
'.BackColor.RGB = RGB(225, 232, 245)
.GradientStops(1).Position = 0
.GradientStops(1).Color = RGB(195, 214, 155)
.GradientStops(2).Position = 1
.GradientStops(2).Color = RGB(225, 232, 245)
' .GradientStops.Insert RGB(247, 247, 247), 0.5 ' добавление при необходимости 3-ей точки градиента
End With
'двухцветная градиентная заливка области построения
With ActiveChart.PlotArea.Format.Fill
.Visible = msoTrue
.TwoColorGradient msoGradientHorizontal, 1
.ForeColor.RGB = RGB(195, 214, 155)
' .BackColor.RGB = RGB(0, 0, 255)
.GradientStops(1).Position = 0
.GradientStops(1).Color = RGB(195, 214, 155)
.GradientStops(2).Position = 1
.GradientStops(2).Color = RGB(225, 232, 245)
' .GradientStops.Insert RGB(247, 247, 247), 0.5 ' добавление при необходимости 3-ей точки градиента
End With
' задание рядов (элементов легенды). У нас значения ячеек, в которых хранятся ФИО сотрудников
' указанного подразделения. «Итоги» - это название листа с данными для диаграммы.
nomRow = rowFrom
i=1
Set seriesCol = ActiveChart.SeriesCollection
For Each mySeries in seriesCol
Set mySeries = ActiveChart.SeriesCollection(i)
With mySeries
' Имя ряда - ФИО сотрудника
.Name = "='Итоги'!$B$" & Format(nomRow)
' выводить подпись данных
.HasDatalabels=True
' подпись данных внутри столбца
.DataLabels.Position = xlLabelPositionInsideEnd
' повернуть подпись данных на 90 градусов
.DataLabels.Orientation = 90
End With
' градиентная заливка ряда данных, 3 точки градиента
With mySeries.Fill
.Visible = msoTrue
.TwoColorGradient msoGradientVertical, 1
Select Case i
Case Is = 1
' зеленый
Call ColorForSerGradient(i, 1, 0, 176, 80 ) ' 1-я точка градиента
Call ColorForSerGradient(i, 2, 0, 176, 80 ) ' 3-я точка градиента
Call ColorForSerGradient(i, 3, 122, 208, 126 ) ' 2-я точка градиента
Case Is = 2
' желтый
Call ColorForSerGradient(i, 1, 238, 181, 0 )
Call ColorForSerGradient(i, 2, 238, 181, 0 )
Call ColorForSerGradient(i, 3, 255, 213, 79 )
Case Is = 3
' красный
Call ColorForSerGradient(i, 1, 255, 79, 37 )
Call ColorForSerGradient(i, 2, 255, 79, 37 )
Call ColorForSerGradient(i, 3, 255, 113, 113 )
Case Is = 4
' оранжевый
Call ColorForSerGradient(i, 1, 255, 102, 0 )
Call ColorForSerGradient(i, 2, 255, 102, 0 )
Call ColorForSerGradient(i, 3, 255, 173, 117 )
Case Is = 5
' синий
Call ColorForSerGradient(i, 1, 55, 123, 205 )
Call ColorForSerGradient(i, 2, 55, 123, 205 )
Call ColorForSerGradient(i, 3, 111, 160, 219 )
Case Is = 6
' фиолетовый
Call ColorForSerGradient(i, 1, 96, 74, 123 )
Call ColorForSerGradient(i, 2, 96, 74, 123 )
Call ColorForSerGradient(i, 3, 161, 140, 186 )
Case Is = 7
' хаки
Call ColorForSerGradient(i, 1, 148, 138, 84 )
Call ColorForSerGradient(i, 2, 148, 138, 84 )
Call ColorForSerGradient(i, 3, 185, 176, 133 )
Case Else
' для ряда > 7 цвет по умолчанию
End Select
End With
With mySeries.Format
.ThreeD.Visible = True
.ThreeD.BevelTopType = msoBevelCircle ' тип рельефа сверху
.ThreeD.BevelTopDepth = 4 ' здесь устанавливается следующий параметр (формат рядов данных->формат объемной фигуры->Рельеф->сверху->высота и ширина
.ThreeD.BevelTopInset = 4
.ThreeD.BevelBottomType = msoBevelCircle ' тип рельефа снизу
.ThreeD.BevelBottomDepth = 6 ' здесь устанавливается следующий параметр (формат рядов данных->формат объемной фигуры->Рельеф->снизу->высота и ширина
.ThreeD.BevelBottomInset = 6
End With
nomRow = nomRow + 1
i = i + 1
Next ' следующий ряд
' Задать подписи горизонтальной оси – они в шапке таблицы, во 2-ой строке листа, в столбцах D-Z,
' но через один. Это периоды, по которым будет выводиться з/п.
' Ошибка при задании дискретного диапазона! Поэтому взяла из непрерывного.
ActiveChart.SeriesCollection(1).XValues = "='Итоги'!$N$1:$Y$1"
End Sub