Весёлые маркеры графиков⁠⁠

Сегодня расскажу про простой способ разукрасить диаграммы, а именно заменить маркеры на произвольные рисунки.

Установка рисунков в качестве маркеров позволяет разнообразить внешний вид документации, сделав её нагляднее. Установка смайлов (© http://www.kolobok.us/ ) сделана в качестве примера (помните про Aiwan то? Или забыли...).

Для гармоничного отображения требуется проредить количество маркеров, в противном случае произойдёт наложение рисунков друг на друга. О прореживании писал ранее.

Заменить маркеры на рисунки, в данном случае они представлены смайлами, можно при помощи не сложного макроса

Sub Markers_Smiles()

ActiveSheet.ChartObjects("Диаграмма 1").Activate

For Each icell In [C2:C102]

ActiveChart.FullSeriesCollection(1).Points(icell.Row - 1).Select

' Убираю рамки вокруг маркеров

Selection.MarkerForegroundColorIndex = xlNone

' Установка типа маркера «Рисунок»

Selection.MarkerStyle = -4147

Selection.Format.Fill.UserPicture "D:\4.gif"

If icell.Value = 0 Then Selection.Format.Fill.UserPicture "D:\1.gif"

If icell.Value = 1 Then Selection.Format.Fill.UserPicture "D:\2.gif"

If icell.Value = 2 Then Selection.Format.Fill.UserPicture "D:\3.gif"

Next

End Sub

Где

[C2:C102] - столбец с признаками маркера. Число элементов равно числу данных (Х или Y). Может как заполняться вручную, так и быть расчётным (см.рисунок ниже).

D:\1.gif ... D:\4.gif - пути к рисункам.

Аналогично производится заполнение рисунками нескольких графиков на диаграмме

Прореживаем

Sub Прореживание_маркеров()

' Активируем диаграмму

ActiveSheet.ChartObjects("Диаграмма 1").Activate

' Перебор по всем графикам диаграммы

For k = 1 To ActiveChart.FullSeriesCollection.Count

' Удаляем все маркеры на линии

For i = 1 To ActiveChart.SeriesCollection(k).Points.Count

ActiveChart.FullSeriesCollection(k).Points(i).Select

Selection.MarkerStyle = -4142

Next i

' Выставляем маркеры с требуемым шагом.

For i = 1 To ActiveChart.SeriesCollection(k).Points.Count Step 4

ActiveChart.FullSeriesCollection(k).Points(i).Select

With Selection

.MarkerStyle = 8

.MarkerSize = 15

End With

Next i

Next k

End Sub

Проставляем рисунки

Public Sub color_graph()

ActiveSheet.ChartObjects("Диаграмма 1").Activate

For k = 1 To ActiveChart.FullSeriesCollection.Count ' Перебор по всем графикам

For Each icell In [C2:C102]

ActiveChart.FullSeriesCollection(k).Points(icell.Row - 1).Select

Selection.MarkerStyle = -4147

Selection.Format.Fill.UserPicture "D:\4.gif"

If icell.Value = 0 Then Selection.Format.Fill.UserPicture "D:\1.gif"

If icell.Value = 1 Then Selection.Format.Fill.UserPicture "D:\2.gif"

If icell.Value = 2 Then Selection.Format.Fill.UserPicture "D:\3.gif"

Next

Next k

End Sub

Аналогично разным графикам одной диаграммы можно присвоить уникальные маркеры

Sub Markers()

ActiveSheet.ChartObjects("Диаграмма 1").Activate

For i = 1 To ActiveChart.FullSeriesCollection.Count ' Перебор по всем графикам

ActiveChart.FullSeriesCollection(i).Select

Selection.MarkerForegroundColorIndex = xlNone

Selection.MarkerStyle = -4147

If i = 1 Then Selection.Format.Fill.UserPicture "D:\1.gif"

If i = 2 Then Selection.Format.Fill.UserPicture "D:\2.gif"

If i = 3 Then Selection.Format.Fill.UserPicture "D:\3.gif"

If i = 4 Then Selection.Format.Fill.UserPicture "D:\4.gif"

If i = 5 Then Selection.Format.Fill.UserPicture "D:\5.gif"

Next i

End Sub

Ну или просто разными штатными маркерами разные графики. Но в автоматическом режиме - очень сокращает время подготовки документации. Полезно при подготовке к печати в чёрно-белом варианте.

Sub Установка_разных_маркеров()

ActiveSheet.ChartObjects("Диаграмма 1").Activate

For i = 1 To ActiveChart.FullSeriesCollection.Count ' Перебор по всем графикам

ActiveChart.FullSeriesCollection(i).Select

Selection.Format.Line.ForeColor.RGB = RGB(0, 0, 0) ' Цвета линий и маркера

Selection.Format.Line.Weight = 0.75 ' Установка толщины линии

Selection.MarkerStyle = i ' Установка типа маркера

Selection.MarkerSize = 4 ' Установка размера маркера

Selection.Format.Fill.ForeColor.RGB = RGB(255, 255, 255) ' Установка заливки маркера

Next i

End Sub

Можно ли это сделать без макросов? Несомненно. Долго и нудно кликать кнопочки.

Но как по мне - проще скопировать и немного поправить код простого макроса. А в остальном - ваш выбор.