Excel Chart - using VBA to create and format 1

[dkathrens77]

I am working on an Excel application that programmatically creates a chart. I have the basics of this realized, but the chart size, the titles, axes and data labels seem to choose their own size values, even when I have specified them in VBA.

I got the code to format the titles, axes and data labels by recording a macro while I manually 'cleaned up' the newly created chart.

I can post my code here if anyone wants to see it, but it's rather long so ask first.

 

[SkipVought]

dkathrens77,

Please post code.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at faq222-2244

 

[dkathrens77]

Here's the code. I'm self-taught, so please be gentle. This is Excel 97 by the way.

Public Sub cmdChart()

Dim strActiveSheet As String 'name of the Active Sheet
Dim arDateChange() As String 'an array to hold all possible dates in a month

Dim datDateA As Date 'rememeber a date
Dim datDateB As Date 'remember first date different from preceeding date

Dim intJ As Integer ' 1 to 1000 (lines on the worksheet
Dim intI As Integer ' 1 to 31 (possible dates in the month)

On Error GoTo ErrorHandler

Application.ScreenUpdating = False 'suppress jerky screen behavior
strActiveSheet = ActiveSheet.Name
intI = 1
'Note the address of the first date entered
' = Range ("A5") in arDateChange(1)
'
'Go down the column of dates, looking for
' the first cell where the date is different
' from the preceeding array element
'
' Note the cell value in next available array element
' repeat this process to the last date entered on the sheet

With Worksheets(ActiveSheet.Name).Range("$A$5:$A$1000")
.Select 'Activate the column of dates
Range("A5").Activate 'the first date entered on this sheet

datDateA = ActiveCell.Value 'remember the first date
'Debug.Print "datDateA = " & datDateA
ReDim Preserve arDateChange(1)
arDateChange(1) = ActiveCell.Address 'start recording
' addresses of distinct dates in the array
'Debug.Print "arDateChange(1) = " & arDateChange(1)

End With

For intJ = 5 To 1000 'step down each line on the worksheet
' looking for date changes
Range("A" & intJ).Select
Select Case Range("A" & intJ).Value
Case Is = datDateA
'do nothing
Case IsNull(Range("A" & intJ).Value) 'no more entries
Exit For
Case Else
'record the cell address of the new date
intI = intI + 1
ReDim Preserve arDateChange(intI)
arDateChange(intI) = Range("A" & intJ).Address
'Debug.Print "arDateChange(" & intI & ") = " & arDateChange(intI)
'Debug.Print "Value = " & Range(arDateChange(intI)).Value
datDateA = Range("A" & intJ).Value
'Debug.Print "datDateA = " & datDateA
End Select
'Stop
Next 'intJ
'
'starting at B1001, start entering formulas in the column of cells
' to COUNTIF() based on the date in the first date array element
For intI = 1 To UBound(arDateChange)
With Range("B" & 1000 + intI)
.Select
.Formula = "=COUNTIF($A$5:$A$1000," & arDateChange(intI) & ")"
'Debug.Print "Changed Date Address = " & arDateChange(intI)
'Debug.Print Range(arDateChange(intI)).Value
End With

With Range("D" & 1000 + intI)
.Select
If Not Range(arDateChange(intI)).Value = "" Then
.Value = Range(arDateChange(intI)).Value
'Debug.Print "On date " & .Value
End If
End With 'Range
Next 'intI

'build a chart on shtCharts based on the counts and dates collated
'
Worksheets(strActiveSheet).Range("B10011031").Select

intI = Sheets("Charts").Shapes.Count 'get the number of the latest chart object

If Sheets("Charts").Shapes(intI).Name <> strActiveSheet Then
'don't make a new chart if one already exists for this worksheet
Charts.Add
ActiveChart.SetSourceData Source:=Sheets(strActiveSheet).Range("B100110031")
'this is the column of daily load numbers
ActiveChart.Location _
Where:=xlLocationAsObject, _
Name:="Charts"
'add chart as object on shtCharts

intI = Sheets("charts").Shapes.Count 'get the number of the latest chart object
Sheets("Charts").Shapes(intI).Name = strActiveSheet
'name the new chart to match the sheet it came from
ActiveChart.PlotArea.Select

For intI = 1 To ActiveChart.SeriesCollection.Count - 1
ActiveChart.SeriesCollection(intI).Delete
Next 'delete all old data series

ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(1).Values = Worksheets(strActiveSheet).Range("B1001:B1031")
ActiveChart.SeriesCollection(1).Name = "Loads"

With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = _
"Loads for " & strActiveSheet
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Dates"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Loads"
'can we change the font size?
.HasAxis(xlCategory, xlPrimary) = True
.HasAxis(xlValue, xlPrimary) = True
End With

ActiveChart.Axes(xlCategory, xlPrimary).CategoryType = xlTimeScale
ActiveChart.HasLegend = False
ActiveChart.ApplyDataLabels Type:=xlDataLabelsShowValue, LegendKey:=False

'*********************************************************
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = "6/1/2004" 'How to code automatic first of month?
.MaximumScale = "6/30/2004" 'How to code automatic last of month?
.BaseUnitIsAuto = True
.MajorUnit = 1
.MajorUnitScale = xlDays
.MinorUnitIsAuto = True
.Crosses = xlCustom
.CrossesAt = "6/1/2004" 'automatic first of month?
.AxisBetweenCategories = False
.ReversePlotOrder = False
End With

'Selection.TickLabels.AutoScaleFont = True
With Selection.TickLabels.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With

Selection.TickLabels.Orientation = 45

ActiveChart.Axes(xlValue).Select
With ActiveChart.Axes(xlValue)
.MinimumScaleIsAuto = True
.MaximumScale = 50
.MinorUnit = 1
.MajorUnit = 10
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
End With

ActiveChart.SeriesCollection(1).XValues = _
Worksheets(strActiveSheet).Range("D10011031")

ActiveChart.ChartArea.Select
ActiveSheet.Shapes(strActiveSheet). _
ScaleWidth 3, msoFalse, msoScaleFromTopLeft

ActiveSheet.Shapes(strActiveSheet). _
ScaleHeight 3, msoFalse, msoScaleFromTopLeft

ActiveChart.Axes(xlCategory).Select
'Selection.TickLabels.AutoScaleFont = True

With Selection.TickLabels.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With

ActiveChart.SeriesCollection(1).DataLabels.Select
'Selection.AutoScaleFont = True
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With

Else ' the chart already exists, just quit
MsgBox "Will not create Duplicate Chart", _
vbCritical, _
"Chart for " & strActiveSheet & " Already Exists!"
GoTo Sub_Exit

End If '
'*********************************************************

Sub_Exit:

Application.ScreenUpdating = True
Exit Sub

ErrorHandler:

Application.ScreenUpdating = True
MsgBox Err.Description, vbCritical, "Error: " & Err.Number
GoTo Sub_Exit

End Sub

 

[SkipVought]

It would also be helpful to post a sample of your source data.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at faq222-2244

 

[dkathrens77]

er, uh, how do I do that? Is there some way to attach a worksheet, or do you want an inline text representation of the data?

Short description:

each line in the worksheet is input manually to track truck loads dispatched during a month.

There are 1000 lines for data input, and starting at line 1001 thru 1031, lines for countif values for each day in the list.

The chart uses this range (B10011031) as its source data.



There is code to scan the list and compile daily load counts at the bottom of the sheet

 

[SkipVought]

So you have 3 columns of data.

Just post the 3 headings and 4-5 rows of data.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at faq222-2244

 

[dkathrens77]

Here is a sample of the manually entered data

Date PRO# Unit# Name Origin Destination
6/1/04 0606306 4771 Graham CO IN
6/1/04 0606312 4763 Beights CO GA
6/1/04 0606315 4592 Carey CO MO
6/1/04 0606323 4590 Gaudet WA CO
6/1/04 0606327 4640 Brown NE OK


Here are the collated counts

23 Loads On: 6/1/04
25 Loads On: 6/2/04
19 Loads On: 6/3/04
25 Loads On: 6/4/04
24 Loads On: 6/7/04
19 Loads On: 6/8/04
18 Loads On: 6/9/04
21 Loads On: 6/10/04
23 Loads On: 6/11/04
19 Loads On: 6/14/04
11 Loads On: 6/15/04
15 Loads On: 6/16/04
13 Loads On: 6/17/04
21 Loads On: 6/18/04
5 Loads On: 6/21/04
1 Loads On: 6/22/04
1 Loads On: 6/23/04
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:
Loads On:

 

[SkipVought]

Here is a way to position and size the FIRST chart

   With Sheets("Charts").ChartObjects(1)
       .Top = Application.InchesToPoints(1.5)
       .Left = Application.InchesToPoints(1.5)
       .Width = Application.InchesToPoints(4)
       .Height = Application.InchesToPoints(4)
   End With

The position and size of the other items you mentioned depends on factors like font size of the titles.

Let me know if this helps and if you need specific help anywhere else.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at faq222-2244

 

[dkathrens77]

Thanks Skip, that worked like gangbusters!

Now I just have to count the number of charts and do some math to increment the .Top position of the new chart on the sheet.

Piece of cake!

 

[SkipVought]

dim co as chartobject
for each co in activesheet.chartobjects
  with co
    .top=...
    .left=...
    .width=...
    .height=...
  end with
next

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at faq222-2244

 

[MarkGorecki]

This is great, but how would a newbie (like myself) be able to select the cell range using a cursor, instead of hard coding the cell range, then pass the range on to the code?

 

[SkipVought]

MarkGorecki,

Please post your question in a NEW THREAD.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at faq222-2244