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("B1001

1031").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("B1001

10031")
'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("D1001

1031")
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