Sub CreateCSMChart(CSM As String, Startingdate As Date)
' This subroutine formats a chart for a specific CSM
Dim recData As DAO.Recordset, rst As DAO.Recordset
Dim dbs As Database
Dim varArray As Variant, CSA As String
Dim objExcel As Object, objBook As Object
Dim objSheet As Object, objChart As Object
Dim intFields As Integer, intRows As Integer
Dim intFld As Integer, intRow As Integer, StartDate As Date, EndDate As Date
Dim strRange As String, strCriteria As String, strSaveFile As String
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objBook = objExcel.Workbooks
objBook.Add
Set objSheet = objExcel.Sheets("Sheet1")
Set objChart = objExcel.Charts
Set dbs = CurrentDb
StartDate = Startingdate - 35
EndDate = Startingdate
DoCmd.Hourglass True ' Set cursor to Hourglass while running
strCriteria = "Select * from qryCSMChartSource where CSM = '" & CSM & "' and WeekCom between #" & Format$(StartDate, "mm/dd/yyyy") & "# and #" & Format$(EndDate, "mm/dd/yyyy") & "#"
Set recData = dbs.OpenRecordset(strCriteria)
' Span all of dataset to ensure recordcount is correct
recData.MoveLast
recData.MoveFirst
' Extract data from Query into varArray
varArray = recData.GetRows(recData.RecordCount)
intFields = UBound(varArray, 1)
intRows = UBound(varArray, 2)
'objSheet.Add 'Creates a new Excel workbook
'objExcel.Visible = True ' Hides the workbook from the desktop
' Format the worksheet
objExcel.Sheets("Sheet1").PageSetup.Orientation = xlLandscape
' Copy the column headings from the data and format
For intFld = 1 To intFields
objExcel.Cells(intRow + 1, intFld + 1).Value = recData.Fields(intFld).Name
objExcel.Cells(intRow + 1, intFld + 1).Font.Bold = True
objExcel.Cells(intRow + 1, intFld + 1).Font.Size = 12
Next
' Insert Heading for Column A
objExcel.Cells(1, 1).Value = "Week Commencing"
objExcel.Cells(1, 1).Font.Bold = True
objExcel.Cells(1, 1).Font.Size = 12
recData.Close ' Close the Dataset
For intFld = 0 To intFields
For intRow = 0 To intRows
'Populate the spread sheet Column by Column - Row by Row
objExcel.Cells(intRow + 2, intFld + 1).Value = varArray(intFld, intRow)
objExcel.Cells(intRow + 2, intFld + 1).HorizontalAlignment = xlCenter
Next
Next
CSM = objExcel.Cells(2, 4).Value
' Hide the two default sheets that are not used.
objExcel.Sheets("Sheet2").Visible = False
objExcel.Sheets("Sheet3").Visible = False
' Select the data range
strRange = "A2:" & Chr$(Asc("A") + intFields - 1) & Format$(intRows + 2)
'strRange = "a2:A4"
objExcel.Range(strRange).Select
objExcel.Range(Mid(strRange, 4)).Activate
objExcel.Application.Charts.Add
Set objChart = objExcel.ActiveChart
With objChart
.HasTitle = True
.ChartTitle.Caption = "Percentage Usage for " & CSM & "'s Team"
.ChartType = xlLineMarkers 'Set chart type
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Caption = "Week Commencing"
On Error Resume Next
.Axes(xlCategory).MajorUnit = 7 'Just show weekly dates
On Error GoTo ErrLab ' Set error trap
' Format the Chart
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Caption = "Usage %"
.HasLegend = True
.SeriesCollection(1).Name = CSM & "'s Team"
.Legend.LegendEntries(1).LegendKey.Border.ColorIndex = 1
.Legend.LegendEntries(1).LegendKey.MarkerBackgroundColorIndex = 1
.Legend.LegendEntries(1).LegendKey.MarkerForegroundColorIndex = 1
.SeriesCollection(2).Name = "=sheet1!R1C3"
.Legend.LegendEntries(2).LegendKey.Border.ColorIndex = 5
.Legend.LegendEntries(2).LegendKey.MarkerBackgroundColorIndex = 5
.Legend.LegendEntries(2).LegendKey.MarkerForegroundColorIndex = 5
End With
' Format data table
objExcel.Sheets("Sheet1").Activate
objExcel.Sheets("Sheet1").Columns("A:E").EntireColumn.AutoFit
objExcel.Sheets("Sheet1").Columns("B").EntireColumn.NumberFormat = "0.00"
objExcel.Sheets("Sheet1").Columns("C").EntireColumn.NumberFormat = "0.00"
objExcel.Sheets("Sheet1").Columns("D").EntireColumn.NumberFormat = "0.00"
objExcel.Sheets("Sheet1").Select
objExcel.Sheets.Move Before:=objExcel.Sheets(1)
objExcel.Sheets("Sheet1").Name = "Data Table" ' rename sheet
objExcel.Sheets("Chart1").Activate
objExcel.Sheets("Chart1").Move Before:=objExcel.Sheets(1)
objExcel.Sheets("Chart1").Name = CSM & "'s Team"
strSaveFile = "H:\Customer Relationship\Knowledge Management (Public)\Knowledge Base Reports\Weekly Report Archive " & Format(Startingdate, "yyyy") _
& "\" & Format(Startingdate, "yyyymmdd") & "\" & CSM & ".xls"
objExcel.ActiveWorkbook.SaveAs FileName:=strSaveFile
objExcel.ActiveWorkbook.Close
objExcel.Quit
Set objChart = Nothing
Set objExcel = Nothing
DoCmd.Hourglass False ' Switch off Hourglass cursor
Exit Sub
Sub CreateSDMChart(SDM As String, Startingdate As Date)
' This subroutine formats a chart for a specific SDM
Dim recData As DAO.Recordset, rst As DAO.Recordset
Dim dbs As Database
Dim varArray As Variant, CSA As String, BusinessUnit As String
Dim objExcel As Object, objBook As Object
Dim objSheet As Object, objChart As Object
Dim intFields As Integer, intRows As Integer
Dim intFld As Integer, intRow As Integer, StartDate As Date, EndDate As Date
Dim strRange As String, strCriteria As String, strSaveFile As String
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objBook = objExcel.Workbooks
objBook.Add
Set objSheet = objExcel.Sheets("Sheet1")
Set objChart = objExcel.Charts
Set dbs = CurrentDb
StartDate = Startingdate - 35
EndDate = Startingdate
DoCmd.Hourglass True ' Set cursor to Hourglass while running
strCriteria = "Select * from qrySDMChartSource where SDM = '" & SDM & "' and WeekCom between #" & Format$(StartDate, "mm/dd/yyyy") & "# and #" & Format$(EndDate, "mm/dd/yyyy") & "#"
' MsgBox (strCriteria)
Set recData = dbs.OpenRecordset(strCriteria)
' Span all of dataset to ensure recordcount is correct
recData.MoveLast
recData.MoveFirst
BusinessUnit = recData!BusinessUnit
' Extract data from Query into varArray
varArray = recData.GetRows(recData.RecordCount)
intFields = UBound(varArray, 1)
intRows = UBound(varArray, 2)
objExcel.Workbooks.Add 'Creates a new Excel workbook
objExcel.Visible = False ' Hides the workbook from the desktop
' Format the worksheet
objExcel.Sheets("Sheet1").PageSetup.Orientation = xlLandscape
' Copy the column headings from the data and format
For intFld = 1 To intFields
objExcel.Cells(intRow + 1, intFld + 1).Value = recData.Fields(intFld).Name
objExcel.Cells(intRow + 1, intFld + 1).Font.Bold = True
objExcel.Cells(intRow + 1, intFld + 1).Font.Size = 12
Next
' Insert Heading for Column A
objExcel.Cells(1, 1).Value = "Week Commencing"
objExcel.Cells(1, 1).Font.Bold = True
objExcel.Cells(1, 1).Font.Size = 12
recData.Close ' Close the Dataset
For intFld = 0 To intFields
For intRow = 0 To intRows
'Populate the spread sheet Column by Column - Row by Row
objExcel.Cells(intRow + 2, intFld + 1).Value = varArray(intFld, intRow)
objExcel.Cells(intRow + 2, intFld + 1).HorizontalAlignment = xlCenter
Next
Next
SDM = objExcel.Cells(2, 4).Value
' Hide the two default sheets that are not used.
objExcel.Sheets("Sheet2").Visible = False
objExcel.Sheets("Sheet3").Visible = False
' Select the data range
strRange = "A2:" & Chr$(Asc("A") + intFields - 2) & Format$(intRows + 2)
objExcel.Range(strRange).Select
' MsgBox (Mid(strRange, 4))
objExcel.Range(Mid(strRange, 4)).Activate
objExcel.Application.Charts.Add
Set objChart = objExcel.ActiveChart
With objChart
.HasTitle = True
.ChartTitle.Caption = "Percentage Usage for " & SDM & "'s Team"
.ChartType = xlLineMarkers 'Set chart type
.Axes(xlCategory).HasTitle = True
.Axes(xlCategory).AxisTitle.Caption = "Week Commencing"
On Error Resume Next
.Axes(xlCategory).MajorUnit = 7 'Just show weekly dates
On Error GoTo ErrLab ' Set error trap
' Format the Chart
.Axes(xlValue).HasTitle = True
.Axes(xlValue).AxisTitle.Caption = "Usage %"
.HasLegend = True
.SeriesCollection(1).Name = SDM & "'s Team"
.Legend.LegendEntries(1).LegendKey.Border.ColorIndex = 1
.Legend.LegendEntries(1).LegendKey.MarkerBackgroundColorIndex = 1
.Legend.LegendEntries(1).LegendKey.MarkerForegroundColorIndex = 1
.SeriesCollection(2).Name = "=Sheet1!R1C3"
.Legend.LegendEntries(2).LegendKey.Border.ColorIndex = 5
.Legend.LegendEntries(2).LegendKey.MarkerBackgroundColorIndex = 5
.Legend.LegendEntries(2).LegendKey.MarkerForegroundColorIndex = 5
End With
' Format data table
objExcel.Sheets("Sheet1").Activate
objExcel.Sheets("Sheet1").Columns("A:E").EntireColumn.AutoFit
objExcel.Sheets("Sheet1").Columns("B").EntireColumn.NumberFormat = "0.00"
objExcel.Sheets("Sheet1").Columns("C").EntireColumn.NumberFormat = "0.00"
objExcel.Sheets("Sheet1").Columns("D").EntireColumn.NumberFormat = "0.00"
objExcel.Sheets("Sheet1").Select
objExcel.Sheets.Move Before:=Sheets(1)
objExcel.Sheets("Sheet1").Name = "Data Table" ' rename sheet
objExcel.Sheets("Chart1").Activate
objExcel.Sheets("Chart1").Move Before:=Sheets(1)
objExcel.Sheets("Chart1").Name = SDM & "'s Team"
strSaveFile = "H:\Customer Relationship\Knowledge Management (Public)\Knowledge Base Reports\Weekly Report Archive " & Format(Startingdate, "yyyy") _
& "\" & Format(Startingdate, "yyyymmdd") & "\" & SDM & ".xls"
objExcel.ActiveWorkbook.SaveAs FileName:=strSaveFile
objExcel.ActiveWorkbook.Close
Set objChart = Nothing
Set objExcel = Nothing
DoCmd.Hourglass False ' Switch off Hourglass cursor
Exit Sub
ErrLab:
' Ignore errors
Resume Next
End Sub ' CreateSDMChart