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
''\\=====================================================================
