I'm updating charts in Powerpoint 2007 from queries in Access 2007.
The charts have been manually added and set up using Insert ~ Object ~ Microsoft Office Excel Chart and should look like this (I've obfuscated the axis labels):
The problem
My Access query returns the data for the selected months, but I then need to add two extra series for the blank spaces between the months.
Currently I place the data in the worksheet, insert blank lines and use a formula to calculate the maximum value for the month, add 2 and minus the raw data value for that month.
An example of the formula is: =MAX(R3C2:R3C17)+2-R3C.
If I step through my code this formula is entered correctly, but if I run the code it appears as =MAX(R3C2:R3C17)+2-R3C[-1] (converted in to A1 style in the sheet) and my chart appears as:
I did try updating the code so the final C is C[+1] and this worked for a little while (but I'm not happy with that as it shouldn't work and I don't know why it does).
The line of code that adds the formula is:
.Range(.cells(x, 2), .cells(x, oLastCell.Column)).FormulaR1C1 = _
"=MAX(R" & x - 1 & "C2:R" & x - 1 & "C" & oLastCell.Column & ")+2-R" & x - 1 & "C"
As you can see I'm using x-1 rather than R[-1] in the formula as R[-1] was returning row 65536 even though the formula is placed in row 3.
The data behind the chart appears like this (you can see where the formula is mucked up an returning an error value as it's trying to reference column A).
The solution I'm looking for:
How to get the formula into the worksheet correctly
(can't believe I'm asking that after starting on Excel 97).
or combining a cross-tab query with calculated data to perform the same function as the formula.
(I'll add the SQL and explain if anyone thinks that would be a better option).
The code to produce the report is below (the code is in Access).
Code entry point:
Option Compare Database
Option Explicit
Private sReportMonth As String 'Text displaying current month.
Private sReportYear As String 'Text displaying current year.
Public Sub Produce_Report()
Dim sTemplate As String 'Path to PPTX Template.
Dim oPPT As Object 'Reference to PPT application.
Dim oPresentation As Object 'Reference to opened presentation.
Dim oSlide As Object 'Reference to slide in PPT.
sTemplate = CurrentProject.Path & "\PPT Template\Reported Errors Template.pptx"
Set oPPT = CreatePPT
Set oPresentation = oPPT.Presentations.Open(sTemplate)
sReportMonth = Forms!frm_CreateReport!lstMonths.Column(1)
sReportYear = Forms!frm_CreateReport!txtYear
'Add the month and year to the Title slide.
Set oSlide = oPresentation.slides(1)
With oSlide
.Shapes("Report_Date").TextFrame.TextRange.Text = sReportMonth & " " & sReportYear
End With
Set oSlide = Nothing
Error_Trends oPresentation.slides(2)
Error_Origin oPresentation.slides(4)
'''''''''''''''''''''''''''''''''''''''''''''''''
'These two procedures produce the chart errors. '
'''''''''''''''''''''''''''''''''''''''''''''''''
Error_Categories oPresentation.slides(5)
TeamBreakdown oPresentation.slides(6)
MsgBox "Complete"
End Sub
TeamBreakdown code:
(Error_Categories is the same - I'll be combining once I know what's going on).
Private Sub TeamBreakdown(oSlide As Object)
Dim oWrkSht As Object
Dim oWrkCht As Object
Dim oLastCell As Object
Dim rst As DAO.Recordset
Dim prm As DAO.Parameter
Dim qdf As DAO.QueryDef
Dim x As Long
Dim itm As Variant
With oSlide
With .Shapes("chtTeamBreakdown")
Set oWrkSht = .oleformat.Object.worksheets(1)
Set oWrkCht = .oleformat.Object.Charts(1)
End With
End With
Set oLastCell = LastCell(oWrkSht)
With oWrkSht
.Range(.cells(1, 1), oLastCell).ClearContents
End With
Set qdf = CurrentDb.QueryDefs("SQL_REPORT_LSCTeamBreakdown")
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rst = qdf.OpenRecordset
x = 2
With rst
'Place the headings first.
For Each itm In .Fields
oWrkSht.cells(1, itm.CollectionIndex + 1) = itm.Name
Next itm
.MoveFirst
'Place the values.
Do While Not .EOF
For Each itm In .Fields
oWrkSht.cells(x, itm.CollectionIndex + 1) = itm.Value
Next itm
x = x + 1
.MoveNext
Loop
.Close
End With
Set oLastCell = LastCell(oWrkSht)
With oWrkSht
'Add spacer rows to the raw data (equal to the maximum value in the row above plus 2 minus the value directly above).
For x = oLastCell.row To 3 Step -1
.Rows(x).Insert Shift:=-4121, CopyOrigin:=0 '-4121 = xlDown, 0 = xlFormatFromLeftOrAbove
.Range(.cells(x, 2), .cells(x, oLastCell.Column)).FormulaR1C1 = _
"=MAX(R" & x - 1 & "C2:R" & x - 1 & "C" & oLastCell.Column & ")+2-R" & x - 1 & "C"
'Next line produces =MAX($B65536:$P65536)+2-A$2 (when entered in B3).
' .Range(.cells(x, 2), .cells(x, oLastCell.Column)).FormulaR1C1 = _
' "=MAX(R[-1]C2:R[-1]C" & oLastCell.Column & ")+2-R" & x - 1 & "C"
Next x
Set oLastCell = LastCell(oWrkSht)
oWrkCht.SetSourceData .Range(.cells(1, 1), oLastCell), 1 'xlByRows
End With
RefreshChart oSlide.Application, 6, oSlide.Shapes("chtTeamBreakdown")
Set rst = Nothing
Set qdf = Nothing
Set oWrkSht = Nothing
Set oWrkCht = Nothing
End Sub
Code to find last cell (as its used in the formula):
Public Function LastCell(wrkSht As Object, Optional col As Long = 0) As Object
Dim lLastCol As Long, lLastRow As Long
On Error Resume Next
With wrkSht
If col = 0 Then
lLastCol = .cells.Find("*", , , , 2, 2).Column
lLastRow = .cells.Find("*", , , , 1, 2).row
Else
lLastCol = .cells.Find("*", , , , 2, 2).Column
lLastRow = .Columns(col).Find("*", , , , 2, 2).row
End If
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set LastCell = wrkSht.cells(lLastRow, lLastCol)
End With
On Error GoTo 0
End Function
