Solved

How to have consistent colouring of excel charts in many tabs

Posted on 2016-07-17
17
56 Views
Last Modified: 2016-08-31
I have an excel file about 20 tabs of data and graphs and I want to have consistence colouring through out all tables
I have created a tap called Lookup Codes which contains all the description id all graphs headings and their associated colour.

I found some code on the web the almost works but I can't get it to work with all graphs in all tabs, any ideas

The attached file is a striped down file I have been using to get a basic solution and my VBA skills are basic
Color-chart-columns-by-cell-color1.xlsm
0
Comment
Question by:flemingg62
  • 7
  • 7
  • 2
  • +1
17 Comments
 
LVL 17

Expert Comment

by:Karen Falandays
ID: 41717504
Hi flemingg62,
why do you need VBA? Why not just format one table and save it as a template? Then your formatting and colors will be listed in the chart types as your personal template
kfalandays
0
 

Author Comment

by:flemingg62
ID: 41717790
Hi
Thanks I tried templates and I can't get it to keep the same colour for an item. i.e I want  "Vacant" to be blue but Vacant can occur in a different position in the list. Sometime it is 4th, sometime it is 8th. The chart template appears to always assign the same colour to the row. i.e. the 3rd item will always the same colour no matter what the description is .
0
 
LVL 17

Expert Comment

by:Karen Falandays
ID: 41717814
Oh I see, that makes sense then to use VBA
kfalandays
0
 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 41718229
Hi,
I have created a tap called Lookup Codes which contains all the description id all graphs headings and their associated colour.
Could you send an example of that

Regards
0
 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 41719453
pls try
Sub ColorChartColumnsbyCellColor()

For Each sh In Worksheets
    For Each chObj In sh.ChartObjects
        With chObj.Chart.SeriesCollection(1)
            Set vAddress = Range(Split(Split(.Formula, ",")(1), "!")(1))
            For Idx = 1 To vAddress.Count
                res = 0
                On Error Resume Next ' find corresponding XValue
                res = WorksheetFunction.Match(vAddress.Cells(Idx), Sheets("Sheet3").Range("A1:A5"), 0)
                On Error GoTo 0
                If res <> 0 Then ' if found
                    .Points(Idx).Format.Fill.ForeColor.RGB = Sheets("Sheet3").Range("A1").Offset(res - 1, 1).Interior.Color
                End If
            Next
        End With
    Next
Next
End Sub

Open in new window

Regards
Color-chart-columns-by-cell-color1-.xlsm
0
 

Author Comment

by:flemingg62
ID: 41719962
Thanks Traveling for the next 2 days, will try on Friday
0
 

Author Comment

by:flemingg62
ID: 41726459
Hi
Thanks for the code. I tried it and it works perfectly, bar one problem. Most of my graphs are Power Pivot and I keep getting out of ranges error. I have tried a few variations but no luck

I have attached a file that contains one power pivot tab (and 3 tabs of standard charts), any idea?
Test-colours-Charts-with-Power-Pivo.xlsm
0
 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 41726482
Not at my usual place(unable to open the file)

I changed the first code to read directly the values of the chart

Sub ColorChartColumnsbyCellColor()
Dim aXVal()
For Each sh In Worksheets
    For Each chObj In sh.ChartObjects
        With chObj.Chart.SeriesCollection(1)
            aXVal = .XValues
            For Idx = 1 To UBound(aXVal)
                res = 0
                On Error Resume Next ' find corresponding XValue
                res = WorksheetFunction.Match(aXVal(Idx), Sheets("Sheet3").Range("A1:A5"), 0)
                On Error GoTo 0
                If res <> 0 Then ' if found
                    .Points(Idx).Format.Fill.ForeColor.RGB = Sheets("Sheet3").Range("A1").Offset(res - 1, 1).Interior.Color
                End If
            Next
        End With
    Next
Next
End Sub

Open in new window

0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 41727090
then try ( your labels have to be unique not like in example: 2 "Meeting")
Sub ColorChartColumnsbyCellColor()
Dim aXVal()
For Each sh In Worksheets
    For Each chObj In sh.ChartObjects
        For Each SerCol In chObj.Chart.SeriesCollection
            With SerCol
                aXVal = .XValues
                For Idx = 1 To UBound(aXVal)
                    res = 0
                    On Error Resume Next ' find corresponding XValue
                    res = WorksheetFunction.Match(aXVal(Idx), Sheets("Sheet1").Range("A2:A25"), 0)
                    On Error GoTo 0
                    If res <> 0 Then ' if found
                        .Points(Idx).Format.Fill.ForeColor.RGB = Sheets("Sheet1").Range("A2").Offset(res - 1, 2).Interior.Color
                    End If
                Next
            End With
        Next
    Next
Next
End Sub

Open in new window

0
 

Author Comment

by:flemingg62
ID: 41727740
Hi
Thanks very much that solved the problem with power pivots. But when I run it in my main reports not all graphs are updated. In it I have a tab called Lookup Colours (to be hidden at the end) and 3 tabs update and 3 don't. I have set up a secondary column of grey so I can see the one that work ( I just change the column reference when I want to run a different colour scheme). Any Idea

Thanks again for you help so far.
BI-Depaartmental-Reports-9.xlsm
0
 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 41727952
then try
Sub ColorChartColumnsbyCellColor()
Dim aXVal()
For Each sh In Worksheets
Debug.Print sh.Name
    For Each chObj In sh.ChartObjects
        With chObj.Chart.SeriesCollection(1)
            aXVal = .XValues
            For Idx = 1 To UBound(aXVal)
                res = 0
                On Error Resume Next ' find corresponding XValue
                res = WorksheetFunction.Match(aXVal(Idx), Range(Sheets("LookUp Colours").Range("A1"), Sheets("LookUp Colours").Range("A" & Rows.Count).End(xlUp)), 0)
                On Error GoTo 0
                If res <> 0 Then ' if found
                    .Points(Idx).Format.Fill.ForeColor.RGB = Sheets("LookUp Colours").Range("A1").Offset(res - 1, 1).Interior.Color
                End If
            Next
        End With
    Next
Next

End Sub

Open in new window

You change the name of the sheet (case sensitive)
0
 

Author Comment

by:flemingg62
ID: 41728072
Hi
Thanks and sorry to be a pain, but there is no change, i.e. graph in W1, W3 & M2 won't colour as per the tab "LookUp Colours".
And I assume the comment about case sensitive refers to "LookUp Colours".
0
 
LVL 49

Expert Comment

by:Rgonzo1971
ID: 41728818
runned the macro and this is the result where is the problem exactly
BI-Depaartmental-Reports-9v1.xlsm
0
 

Author Comment

by:flemingg62
ID: 41730193
When I run the code only half the charts are updated. If I switch the colour to use the grey colour in Column C of Lookup Colour
 (       .Points(Idx).Format.Fill.ForeColor.RGB = Sheets("LookUp Colours").Range("A1").Offset(res - 1, 2).Interior.Color)
So all charts that change colour are Grey. You will see that not all charts are updated. i.e. Tab W3 won't update but tab W2 will
0
 
LVL 49

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 41730640
then try
Sub ColorChartColumnsbyCellColor()
Dim aXVal()
For Each sh In Worksheets
Debug.Print sh.Name
    For Each chObj In sh.ChartObjects
        For Each SerCol In chObj.Chart.SeriesCollection
            With SerCol
                res = 0
                On Error Resume Next ' find corresponding SerieName
                res = WorksheetFunction.Match(SerCol.Name, Range(Sheets("LookUp Colours").Range("A1"), Sheets("LookUp Colours").Range("A" & Rows.Count).End(xlUp)), 0)
                On Error GoTo 0
                If res <> 0 Then ' if found$
                    SerCol.Format.Fill.ForeColor.RGB = Sheets("LookUp Colours").Range("A1").Offset(res - 1, 1).Interior.Color
                Else
                    aXVal = .XValues
                    For Idx = 1 To UBound(aXVal)
                        res = 0
                        On Error Resume Next ' find corresponding XValue
                        res = WorksheetFunction.Match(aXVal(Idx), Range(Sheets("LookUp Colours").Range("A1"), Sheets("LookUp Colours").Range("A" & Rows.Count).End(xlUp)), 0)
                        On Error GoTo 0
                        If res <> 0 Then ' if found
                            .Points(Idx).Format.Fill.ForeColor.RGB = Sheets("LookUp Colours").Range("A1").Offset(res - 1, 1).Interior.Color
                        End If
                    Next
                End If
            End With
        Next
    Next
Next

End Sub

Open in new window

1
 

Author Comment

by:flemingg62
ID: 41730745
Brilliant works a treat
0
 
LVL 13

Expert Comment

by:frankhelk
ID: 41777733
No comment has been added to this question in more than 21 days, so it is now classified as abandoned.

I have recommended this question be closed as follows:

Accept: Rgonzo1971 (https:#a41730640)

If you feel this question should be closed differently, post an objection and the moderators will review all objections and close it as they feel fit. If no one objects, this question will be closed automatically the way described above.

frankhelk
Experts-Exchange Cleanup Volunteer
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

929 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now