Is it possible to match color from graphs, pie and cells?

espenskeie

Well-known Member
Joined
Mar 30, 2009
Messages
636
Office Version
  1. 2016
Platform
  1. Windows
Hello

I have a setup where I show a graph, and have a pie where the sizes are shown. The size is coming from cells P6:P11.

Is there a system when it comes to coloring these things? And can I somehow add the same color to my cells in range P6:P11?

Here's what I have to create the graphs:

Code:
Sub Graphics()


    Dim wb As Workbook
    Dim ws As Worksheet, wsY As Worksheet
    Dim lr As Long, sht As Long
    Dim getdate As Date, todate As Date
    Dim shtName As String
    Dim Chart2 As ChartObject
    Dim wsX As Worksheet
    Dim dayRate As Double
    Dim LastCol As Integer
    Dim b As Long, k As Long
    
    
       Set wb = ThisWorkbook
       Set ws = wb.Sheets("Graphics")
       
       '''''Clear all data series from chart...
        ws.ChartObjects("Chart 2").Activate
        With ActiveChart
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
        End With
        
        ws.Range("O7:O12", "Q7:Q12").ClearContents
        
        With Worksheets("All")
        lr = .Range("A5").End(xlDown).Row
        
        getdate = Sheets("Graphics").Range("P3").Value
        Res1 = Application.Match(CLng(getdate), .Range("A2:A" & lr), 0)
        
        todate = Sheets("Graphics").Range("P4").Value
        Res2 = Application.Match(CLng(todate), .Range("A2:A" & lr), 0)
        End With
        
        With Sheets("Bonds")
            dayRate = ws.Range("Q3").Value / 365
            
            .Range("C" & Res1).Value = dayRate
            .Range("C" & Res1 + 1).Formula = "=C" & Res1 & "+" & dayRate & ""
            .Range("C" & Res1 + 1).AutoFill Destination:=.Range("C" & Res1 + 1 & ":C" & Res2)
        End With
        
    For Each wsX In ThisWorkbook.Worksheets
                If wsX.Name <> "Graphics" Then 'And wsX.Name <> "All" Then
                k = k + 1
             
                shtName = wsX.Name
                
                Sheets(shtName).Activate
                
                    With ActiveSheet
                       If wsX.Name <> "All" Then
                            Worksheets("All").Cells(4, k + 2) = wsX.Name
                            .Range("C" & Res1 & ":C" & Res2).Copy Destination:=Worksheets("All").Cells(Res1, k + 2)
                        End If
                        
                            If wsX.Name = "All" Then
                                With Worksheets("All")
                                    .Columns("C:BB").Clear
                                    .Cells(4, 3) = wsX.Name
                                    .Range("C" & Res1).FormulaR1C1 = "=SUM(RC[1]:RC[" & Sheets.Count - 2 & "])"
                                    .Range("C" & Res1).AutoFill Destination:=.Range("C" & Res1 & ":C" & Res2)
                                End With
                            End If
                        
                        ws.Names.Add Name:="" & shtName & "", RefersToR1C1:="='" & shtName & "'!R" & Res1 + 1 & "C3:R" & Res2 + 1 & "C3"
                        ws.Names("" & shtName & "").Comment = ""
                    End With
                    
                ws.ChartObjects("Chart 2").Activate
                ActiveChart.SeriesCollection.NewSeries
                ActiveChart.SeriesCollection(k).XValues = "='All'!A" & Res1 + 1 & ":A" & Res2 + 1 & ""
                ActiveChart.SeriesCollection(k).Values = Range(shtName)
                ActiveChart.SeriesCollection(k).Name = shtName
                End If
                
            
                If IsError(Application.Match(wsX.Name, Array("Graphics", "All", "Bonds"), 0)) Then ' Add sheets name and count number of stocks
                    b = b + 1
                    With wsX
                        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 3
                    End With
                            ws.Range("O" & b + 6).Value = wsX.Name
                            ws.Range("Q" & b + 6).Value = LastCol
                End If
    Next
    wb.Save
        
End Sub

Kind regards
Espen
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

Forum statistics

Threads
1,203,687
Messages
6,056,747
Members
444,888
Latest member
Babi_mn

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top