Help Improving VBA to update Chart Formats
 

Hi,
I have the following routine that goes through each chart object on a
Dashboard Report Page and updates various formatting options based on what
data I have showing in the chart.

I cobbled some recorded macros with the know-how I have but have a feeling
there's a better mouse-trap.

I read in a table with color values: chtList (Array)
Then go through each chartand:
change the Background Color
Add Data Labels (seperate routine pasted below which is called by main
routine).
Reformat how many decimals the show based on a field from the chart data.

The routine is very slow and I'm not sure if it's because I do a lot of
selecting, then modify the selection or what.
I've also noticed that the first time I run it after opening excel, it's
relatively fast (About 1.5sec per chart). After I re-run the same macro, it
gets progressively slower each time.

Thanks,
Mike Zz

Sub UpdateChartFormat()
'This macro udpates the series and categories for each chart.

Dim oChart As ChartObject
Dim oSeries As SeriesCollection
Dim s
Dim cht As Object, sh As Worksheet

Const MaxCharts = 8
Const MaxChartProperities = 10
Const FColorCol = 2
Const BColorCol = 3

Dim chtList(1 To MaxCharts, 1 To MaxChartProperities)

For i = 1 To MaxCharts
'Read Chart Name and Colors for that chart
chtList(i, 1) = Range("ChartNameA").Offset(i - 1, -2)
chtList(i, FColorCol) = Range("FirstFColor").Offset(i - 1, 0)
chtList(i, BColorCol) = Range("FirstBColor").Offset(i - 1, 0)
Next i

'Application.ScreenUpdating = False
ActiveSheet.Unprotect

For Each oChart In ActiveSheet.ChartObjects
chtName = oChart.Name
'chtSheet is the Data Sheet Name and also the Chart Name without the
"Chart" text.
chtSheet = Replace(chtName, "Chart", "")
For t = 1 To MaxCharts
If chtList(t, 1) = chtSheet Then
CIndex = t
End If
Next t
fcolor = chtList(CIndex, FColorCol)
BColor = chtList(CIndex, BColorCol)

ymax = Sheets(chtSheet).Range("N2").Value

If Application.WorksheetFunction.IsNumber(ymax) = False Then GoTo
NextChart

Select Case ymax
Case Is 1000
labelDec = 0
Case Is 100
labelDec = 1
Case Is 10
labelDec = 1
Case Else
labelDec = 2
End Select

ActiveSheet.ChartObjects(chtName).Activate

s = ActiveChart.SeriesCollection.Count
ActiveChart.ChartArea.Select
Application.CutCopyMode = False
Call OldV2_Add_Val_Lables_To_Series(s, 6, 0, labelDec)

If Application.WorksheetFunction.IsNumber(yDigits) = True Then
'Set Ydigits
Select Case yDigits
Case 0
yFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
Case 1
yFormat = "_(* #,##0.0_);_(* (#,##0.0);_(* ""-""?_);_(@_)"
End Select
ActiveChart.Axes(xlValue).Select
Selection.TickLabels.NumberFormat = yFormat

'Set Colors
If IsError(fcolor) Then fcolor = 2
If Selection.Fill.ForeColor.SchemeColor = fcolor Then GoTo NextChart
Selection.Fill.Solid
With Selection.Fill
.Solid
.ForeColor.SchemeColor = fcolor
End With

End If
NextChart:
Next

Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub


Sub OldV2_Add_Val_Lables_To_Series(seriesX, fsize, forient, lblDec)
'
' Macro6 Macro
' Macro recorded 5/30/2007 by Autoliv North America
'
Dim NumFormat

ActiveChart.SeriesCollection(seriesX).ApplyDataLab els AutoText:=True,
ShowValue:=True
With ActiveChart.SeriesCollection(seriesX).DataLabels.F ont
.Name = "Times New Roman"
.FontStyle = "Regular"
.Size = fsize
End With
Select Case lblDec
Case 0
NumFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
Case 1
NumFormat = "_(* #,##0.0_);_(* (#,##0.0);_(* ""-""?_);_(@_)"
Case Else
NumFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
End Select
With ActiveChart.SeriesCollection(seriesX).DataLabels
.Orientation = forient
.NumberFormat = NumFormat
End With


End Sub