【发布时间】：2017-02-05 00:31:57
【问题描述】：
我正在根据Access 2007 中的查询更新Powerpoint 2007 中的图表。
图表是使用 Insert ~ Object ~ Microsoft Office Excel Chart 手动添加和设置的，应该如下所示（我已经混淆了轴标签）：
问题
我的 Access 查询返回所选月份的数据，但我需要为月份之间的空格添加两个额外的系列。
目前我将数据放在工作表中，插入空行并使用公式计算当月的最大值，加 2 并减去该月的原始数据值。
公式的一个例子是：=MAX(R3C2:R3C17)+2-R3C.
如果我逐步执行我的代码，则此公式输入正确，但如果我运行代码，它将显示为 =MAX(R3C2:R3C17)+2-R3C[-1]（在工作表中转换为 A1 样式），我的图表显示为：
我确实尝试更新代码，所以最终的 C 是 C[+1] 并且这工作了一段时间（但我对此不满意，因为它不应该工作，我不知道为什么会这样）。
添加公式的代码行是：
.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"
如您所见，我在公式中使用 x-1 而不是 R[-1]，因为 R[-1] 返回第 65536 行，即使公式位于第 3 行。
图表后面的数据如下所示（您可以看到公式在哪里出错，并在尝试引用 A 列时返回错误值）。
我正在寻找的解决方案：
如何将公式正确放入工作表
（不敢相信我在开始使用 Excel 97 后会问这个问题）。
或将交叉表查询与计算数据结合起来执行与公式相同的功能。
（如果有人认为这是一个更好的选择，我会添加 SQL 并解释）。
生成报告的代码如下（代码在 Access 中）。
代码入口点：
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
团队分解代码：
（Error_Categories 是相同的 - 一旦我知道发生了什么，我将合并）。
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
查找最后一个单元格的代码（在公式中使用）：
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
【问题讨论】：
标签： excel vba ms-access ms-access-2007 powerpoint-2007