從Excel 2010更新Powerpoint Graph 2010

Question

我想從Excel 2010更新Powerpoint Graph2010。代碼查找對象，並在Powerpoint中找到名稱相似的范圍，將更改應用於圖形。 圖形格式應該相同，只是必須更新數據。

代碼如下，它無法找到圖表，也無法對其進行更新。

Option Explicit

Private Const NAMED_RANGE_PREFIX = "Export_"
Private Const NAMED_RANGE_PREFIX_TEXT = "ExportText"
Private m_sLog As String

Private Sub CommandButton1_Click()

On Error GoTo Catch

Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape

Dim mgrChart As Chart
Dim mgrDatasheet As Graph.DataSheet

Dim rngData As Excel.Range

Dim iRow As Long, iCol As Long
Dim sTag As String
Dim nFound As Long, nUpdated As Long
Dim nFoundText As Long, nUpdatedText As Long

Dim i As Integer

Dim fLog As frmLog

Dim Box1Status As VbMsgBoxResult

m_sLog = ""

'Prompt to Export
Box1Status = MsgBox("Export and Save to Powerpoint Template?" & Chr(13) & "Reminder: Please use a clean template for export and be sure to back up the template beforehand. " & Chr(13) & Chr(13) & "PLEASE SAVE ANY OTHER OPEN POWERPOINT DOCUMENTS AS ALL UNSAVED WORK WILL BE LOST!", vbQuestion + vbYesNo, "Confirm Export")
If Box1Status = vbNo Then Exit Sub


i = 1

UpdateStatus "Opening Powerpoint presentation '" & Range("fileloc")
Set pptApp = New PowerPoint.Application
pptApp.Activate
Set pptPresentation = pptApp.Presentations.Open(Range("fileloc"))
pptApp.WindowState = ppWindowMinimized

'Looks for (tagged) charts to update

UpdateStatus "Searching presentation for charts..."
For Each pptSlide In pptPresentation.Slides

    For Each pptShape In pptSlide.Shapes


       If pptShape.Type = msoEmbeddedOLEObject Then

       If TypeOf pptShape.OLEFormat.Object Is Graph.Chart Then

                nFound = nFound + 1

                Set mgrChart = pptShape.OLEFormat.Object

                Set mgrChart = pptShape.Chart


                Set mgrDatasheet = mgrChart.Application.DataSheet
                With mgrDatasheet
                    sTag = .Cells(1, 1)
                    If Left(sTag, 6) = "Export" Then UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with tag '" & sTag & "'. Searching Excel workbook for same tag..."
                    Set rngData = RangeForChart(sTag)
                    If rngData Is Nothing Then
                      ' This chart has no data in this Excel workbook
                        If Left(sTag, 6) <> "Export" Then
                            UpdateStatus "Found chart on slide '" & pptSlide.SlideNumber & "' with no tag, skipping"
                        Else
                            UpdateStatus "'" & sTag & "' does not exist in workbook, skipping."
                        End If
                    Else
                      ' Update the PowerPoint chart with the Excel data
                        UpdateStatus "Found '" & sTag & "' at named range '" & rngData.Name & "'. Updating presentation..."
                        .Cells.ClearContents
                        For iRow = 0 To rngData.Rows.Count - 1
                            For iCol = 0 To rngData.Columns.Count - 1
                                .Cells(iRow + 1, iCol + 1) = rngData.Cells(iRow + 1, iCol + 1)
                            Next iCol
                        Next iRow
                        .Application.Update
                        UpdateStatus "Chart with tag '" & sTag & "' updated."
                        nUpdated = nUpdated + 1
                    End If
                End With
                Set mgrDatasheet = Nothing
                mgrChart.Application.Quit
                Set mgrChart = Nothing
           End If
       'End If
    Next pptShape
  i = i + 1
Next pptSlide


UpdateStatus "Finished searching presentation. Closing PowerPoint."

pptPresentation.Save
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing

UpdateStatus "Done. " & nFound & " charts found and " & nUpdated & " charts updated. " & nFoundText & " text boxes found and " & nUpdatedText & " text boxes updated."

Set fLog = New frmLog
fLog.Caption = "Update of Powerpoint Template Complete"
fLog.txtLog.Text = m_sLog
fLog.Show
Unload fLog
Set fLog = Nothing
Exit Sub

Catch:
MsgBox "An unexpected error occurred while updating: " & Err.Number & " " & Err.Description, vbCritical
ForceCleanup mgrChart, mgrDatasheet, pptPresentation, pptApp
End Sub

Private Property Get RangeForChart(sTag As String) As Range
Dim sChartTag As String
Dim iUpdate As Long
Dim NameList As Range
'Dim nRow As Range

Set NameList = Range("Name_List")

If Left(sTag, 6) <> "Export" Then Exit Property

'For Each nRow In NameList.Rows
Do While sChartTag <> sTag

    iUpdate = iUpdate + 1
  ' This will error if there is no named range for "Export_", which means that sTag does not
  ' exist in the workbook so return nothing
    On Error Resume Next
        sChartTag = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange.Cells(1, 1)
        If Err.Number <> 0 Then
          ' Return nothing
            Exit Property
        End If
    On Error GoTo 0
Loop
'Next nRow


Set RangeForChart = ActiveWorkbook.Names(NAMED_RANGE_PREFIX & NameList(iUpdate, 1).Value).RefersToRange

End Property

Private Property Get RangeForText(sTag As String) As Range
Dim sTextTag As String
Dim iUpdate As Long

If Left(sTag, 10) <> "ExportText" Then Exit Property

Do While sTextTag <> sTag
    iUpdate = iUpdate + 1
  ' This will error if there is no named range for "ExportText" & iUpdate, which means that sTag does not
  ' exist in the workbook so return nothing
    On Error Resume Next
        sTextTag = NAMED_RANGE_PREFIX_TEXT & iUpdate
        If Err.Number <> 0 Then
          ' Return nothing
            Exit Property
        End If
    On Error GoTo 0
Loop

Set RangeForText = ActiveWorkbook.Names(NAMED_RANGE_PREFIX_TEXT & iUpdate).RefersToRange

End Property

Private Sub UpdateStatus(sMessage As String)
m_sLog = m_sLog & Now() & ": " & sMessage & vbNewLine
Application.StatusBar = Now() & ": " & sMessage
DoEvents
End Sub

Private Sub ForceCleanup(mgrChart As Graph.Chart, mgrDatasheet As Graph.DataSheet, pptPresentation As PowerPoint.Presentation, pptApp As PowerPoint.Application)
On Error Resume Next
mgrChart.Application.Quit
Set mgrChart = Nothing
mgrDatasheet.Application.Quit
Set mgrDatasheet = Nothing
pptPresentation.Close
Set pptPresentation = Nothing
pptApp.Quit
Set pptApp = Nothing
End Sub  

Answer 1

在Powerpoint圖表的數據表中，您可以通過鍵入以下單元格之一來將這些單元格“鏈接”到excel數據文件（路徑和文件名在此處組成）= c：\\ PPTXfiles \\ excelfiles [excelfiles.xlsx] sheetname'！a1這將創建一個鏈接，該鏈接不會顯示在powerpoint的鏈接部分中，但是可以通過打開兩個文件並雙擊圖表以將其激活來進行更新。 有時，按鏈接粘貼功能不可行，因為文件的最終用戶希望“分解”並發送零件。 沒有源excel文件，這是不可能的，因為最終用戶希望能夠編輯圖表或數據。

如果可以這樣做，然后在發送給最終用戶之前，按VBA中的值復制並粘貼數據表，然后再發送給最終用戶。

Answer 2

am！

Sub UpdateLinks()
    Dim ExcelFile
    Dim exl As Object
    Set exl = CreateObject("Excel.Application")

     'Open a dialog box to promt for the new source file.
    ExcelFile = exl.Application.GetOpenFilename(, , "Select Excel File")

    Dim i As Integer
    Dim k As Integer

     'Go through every slide
    For i = 1 To ActivePresentation.Slides.Count
        With ActivePresentation.Slides(i)
             'Go through every shape on every slide
            For k = 1 To .Shapes.Count
                'Turn of error checking s that it doesn 't crash if the current shape doesn't already have a link
                On Error Resume Next
                 'Set the source to be the same as teh file chosen in the opening dialog box
                .Shapes(k).LinkFormat.SourceFullName = ExcelFile
                If .Shapes(k).LinkFormat.SourceFullName = ExcelFile Then
                     'If the change was successful then also set it to update automatically
                    .Shapes(k).LinkFormat.Update
                End If
                On Error GoTo 0
            Next k
        End With
    Next i
End Sub

Answer 3

我認為您不需要一堆代碼。

在Excel中構建圖表，將其復制，轉到PowerPoint，使用選擇性粘貼-鏈接。 更改Excel中的數據，Excel圖表將更新。 然后打開PowerPoint演示文稿，並在必要時更新鏈接。