MyTetra Share
Делитесь знаниями!
Цвет графика из ячейки
31.07.2019
22:42
Текстовые метки: Chart
Раздел: !Закладки - VBA - Excel - Графики

Sub SetChartColorsFromDataCells()

'https://www.planetaexcel.ru/techniques/4/186/

'(http://www.cyberforum.ru/vba/thread420839.html)

If TypeName(Selection) <> "ChartArea" Then

MsgBox "Сначала выделите диаграмму!"

Exit Sub

End If

Set c = ActiveChart

For j = 1 To c.SeriesCollection.Count

f = c.SeriesCollection(j).Formula

m = Split(f, ",")

Set r = Range(m(2))

' имя листа с данными

strShName_Sourse_Chart = Fn_ShName_in_Formula(f)

'заливка в таблице

Call Copy_Teinte_Cell(r, strShName_Sourse_Chart)

For i = 1 To r.Cells.Count - 1

'цвет столба из ячейки

c.SeriesCollection(j).Points(i).Format.Fill.ForeColor.RGB = _

ThisWorkbook.Sheets(strShName_Sourse_Chart).Cells(r.Cells(i).Row, r.Cells(i).Column - 1).Interior.Color

' r.Cells(i).Interior.Color


'границы столбов

With c.SeriesCollection(j).Points(i).Format.Line

.Visible = msoTrue

.ForeColor.ObjectThemeColor = msoThemeColorText1

.ForeColor.TintAndShade = 0

.ForeColor.Brightness = 0

.Transparency = 0

End With

Next i

Next j

End Sub


'\\------------------------------------------------------------------------------

'\\ копируем заготовленные цвета в ячейки сводной таблицы

Sub Copy_Teinte_Cell(ByVal rRange As Range, _

ByVal strShName_Sourse_Chart As String)

'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Dim strShName As String

Dim rCell As Range, rCellSourse As Range


For Each rCell In rRange.Cells

strVal = Cells(rCell.Row, rCell.Column - 1).Value

Set rCellSourse = Fn_Each_Cells_Teinte_Catalog(ThisWorkbook.Sheets(strShName_Sourse_Chart).Cells(rCell.Row, rCell.Column - 1).Value)

If Not rCellSourse Is Nothing Then

rCellSourse.Copy

ThisWorkbook.Sheets(strShName_Sourse_Chart).Cells(rCell.Row, rCell.Column - 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False

Set rCellSourse = Nothing

End If

Next 'rCell

End Sub


'\\------------------------------------------------------------------------------

'\\ поиск ячейки с цветом на подготовленном листе

Function Fn_Each_Cells_Teinte_Catalog(ByVal strTeinte As String) As Range

Const CONST_strList_Lists As String = "Lists"

Dim intRow As Long, i As Long


With ThisWorkbook.Sheets(CONST_strList_Lists)

intRow = .Columns(1).Rows(65536).End(xlUp).Row

For i = 2 To intRow

If .Cells(i, 1).Value = strTeinte Then Set Fn_Each_Cells_Teinte_Catalog = .Cells(i, 1)

Next i

End With

End Function



'\\------------------------------------------------------------------------------

'\\ извлекаем имя листа из формулы

Function Fn_ShName_in_Formula(ByVal str_Formula As String) As String

Dim m As Variant

'"=SERIES(Chart!$B$10:$B$11,Chart!$A$12:$A$19,Chart!$B$12:$B$19,1)"

m = Split(str_Formula, "!", -1, vbTextCompare)

m = Split(m(LBound(m)), "(", -1, vbTextCompare)

Fn_ShName_in_Formula = m(UBound(m))

End Function



''\\=====================================================================

'Sub SetChartColorsFromDataCells()

'

' If TypeName(Selection) <> "ChartArea" Then

' MsgBox "Сначала выделите диаграмму!"

' Exit Sub

' End If

' Set c = ActiveChart

' For j = 1 To c.SeriesCollection.Count

' f = c.SeriesCollection(j).Formula

' m = Split(f, ",")

' Set r = Range(m(2))

'

' For i = 1 To r.Cells.Count

' c.SeriesCollection(j).Points(i).Format.Fill.ForeColor.RGB = _

' r.Cells(i).Interior.Color

' Next i

' Next j

'End Sub

''\\=====================================================================


 
MyTetra Share v.0.52
Яндекс индекс цитирования