Public Function ClrNo(Clr As String) As Long
Select Case Clr
Case "Blue", "blue"
ClrNo = RGB(0, 102, 204)
Case "Green", "green"
ClrNo = RGB(0, 102, 0)
Case "Amber", "amber"
ClrNo = RGB(255, 153, 0)
Case Else 'red, plus any without a status colour also go red
ClrNo = RGB(255, 0, 0)
End Select
End Function
Public Sub CreateChart()
Dim G As Chart, Wst As Worksheet, R As Range, Y As Range, T As Range, P As Point, Ctr As Byte, N As Long, S As Series
Set Wst = Worksheets(1) '***THIS WILL NEED SETTING TO THE CORRECT SHEET
'Set Wst = ActiveSheet 'use this instead if using button on sheet with data on it
Set R = Wst.Cells.Find("Date", , xlValues, xlWhole) '***Need headings to always be the same for this to work
Set Y = Wst.Cells.Find("Go Live Date", , xlValues, xlWhole) '***Need headings to always be the same for this to work
If R Is Nothing Or Y Is Nothing Then
Wst.Activate
MsgBox "Can't find the data on this worksheet."
Else
Set R = Wst.Range(R.Offset(1, 0), R.End(xlDown))
Set Y = R.Offset(0, Y.Column - R.Column)
Set G = Charts.Add
With G
.Location Where:=xlLocationAsNewSheet
.ChartType = xlLineMarkers
If .SeriesCollection.Count = 0 Then
Set S = .SeriesCollection.NewSeries
Else
Set S = .SeriesCollection(1)
End If
S.XValues = "=" & R.Address(True, True, xlR1C1, True) '***Dates
S.Values = "=" & Y.Address(True, True, xlR1C1, True) '***Delivery dates"
With .Axes(xlCategory, xlPrimary)
.TickLabels.NumberFormat = "dd/mm/yyyy" '***for UK date format
.HasTitle = True
.AxisTitle.Characters.Text = "Update"
End With
With .Axes(xlValue, xlPrimary)
.TickLabels.NumberFormat = "dd/mm/yyyy" '***for UK date format
.HasTitle = True
.AxisTitle.Characters.Text = "Timeline"
End With
.HasLegend = False
.HasTitle = True
.ChartTitle.Text = Wst.Name '***project-specific at the moment
Set T = Wst.Cells.Find("Project", , xlValues, xlWhole)
If Not T Is Nothing Then .ChartTitle.Text = T.Offset(1, 0).Value & " - " & .ChartTitle.Text
End With
With G.Axes(xlValue)
.MinimumScale = #1/1/2009# '39814 '***year-specific at the moment
.MaximumScale = #12/31/2009# '40178 '***year-specific at the moment
.MinorUnitIsAuto = True
.MajorUnit = 14
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
For Ctr = 1 To S.Points.Count
Set P = S.Points(Ctr)
P.MarkerStyle = xlMarkerStyleDiamond
P.MarkerSize = 10
P.Shadow = False
N = ClrNo(Worksheets(1).Cells(Ctr + 1, 4).Value)
P.MarkerBackgroundColor = N
P.MarkerForegroundColor = N
Next Ctr
End If
End Sub
Note that this only works for the sheet you had that had info for a single project on it, not for one with multiple projects.
Bookmarks