continue to have problems placing a large amount of graphs on worksheets.

The program hangs on Runtime Error 1004: No more new fonts may be applied in
this workbook. Sometimes on Runtime Error 1004: Unable to se the HasTitle
propert of the exis class.

I have tried several methods

Dim ChtObj As ChartObject

Dim chtChart As Chart

then cleaning up at the end of each chart placement with

Set chtChart = Nothing


The total amount of datasets is 50
The maximum amount of graphs successfully placed on sheet2 is about 27
The most successful run was with the code below.

Does anyone have a solution to this problem?


Option Explicit
Dim p As Integer
Dim q As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim chartcounter As Integer
Dim chartcolumn As Integer
Dim countvalues As Integer
Dim countrecords As Integer
Dim offset As Integer
Dim var1 As String
Dim ChtObj As ChartObject
Dim chtChart As Chart
Dim mc As Range

Private Sub CommandButton1_Click()
z = 8
y = 5
q = 1
countvalues = 0
countrecords = 0
chartcounter = 1
chartcolumn = 0
offset = 1

Do While Sheet1.Cells(z, 1) < ""
countrecords = countrecords + 1
If Sheet1.Cells(z, 1) < Sheet1.Cells(z + 1, 1) Then

Sheet2.Activate
Set mc = ActiveSheet.Cells(chartcounter, 1)

chartcounter = chartcounter + 15

Charts.Add
ActiveChart.ChartType = xlXYScatter
ActiveChart.SetSourceData Sheet1.Range(Cells(z - countrecords + 1, y),
Cells(z - countrecords + countvalues, y + 1)), PlotBy _
:=xlColumns
ActiveChart.Location Whe=xlLocationAsObject, Name:="Sheet2"
With ActiveChart
..HasTitle = True
..ChartTitle.Characters.Text = Sheet1.Cells(z, 1) & " " &
Sheet1.Cells(1, y + 1)
..Axes(xlCategory, xlPrimary).HasTitle = True
..Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "date"
..Axes(xlValue, xlPrimary).HasTitle = True
..Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "concentration
mg/l"
End With
With ActiveChart.Parent
..Top = Range(mc.Address).Top
..Left = Range(mc.Address).Left
End With


countrecords = 0
countvalues = 0
End If
If Sheet1.Cells(z, y) < "" Then
countvalues = countvalues + 1
End If
z = z + 1
Loop

End Sub