Excel VBA到PPT,代码反复重复地复制相同的图表

时间:2018-07-13 11:49:59

标签: excel vba powerpoint

大家好。我需要一个专业人士来告诉我,我的代码到底发生了什么。您应该知道的可能会影响结果的几件事:

WIN10 Excel 2016 所有统计图都是“数据透视图”,没有任何统计图连接到数据透视表或表,它直接连接到数据模型。 (使用PP实用程序插入的图表)。

因此,下面的代码显示了一个宏,该宏告诉Excel将图表的某些阵列复制到不同的工作表中,并将其粘贴到PowerPoint中的特定幻灯片中。

但是,似乎要一次又一次地复制相同的内容。例如,数组中的第二个图表....它将复制4次,然后按照我告诉它的顺序回到正轨。.因此它将复制图表“ A-02” 4次(跳过应该复制和粘贴的内容),然后继续。

我已经做了很多试验和错误。我已经完全取出图表“ A-02”,但是它只会选择下一个图表并将其复制几次。

我不明白为什么会这样。我希望它一次复制每个图表,然后将其粘贴到指定的幻灯片一次。是什么赋予了?

Sub SCOM_Charts()

ActiveSheet.Shapes.Range(Array("Object 4")).Select
Selection.Verb Verb:=3

If Not Application.CalculationState = xlDone Then
DoEvents
End If

Application.CalculateUntilAsyncQueriesDone

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyChartArray As Variant
Dim X As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

On Error Resume Next

Set PowerPointApp = GetObject(class:="PowerPoint.Application")

Err.Clear

If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, action aborted."
Exit Sub
End If

If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, action aborted."
Exit Sub
End If

On Error GoTo 0

PowerPointApp.ActiveWindow.Panes(2).Activate

Set myPresentation = PowerPointApp.ActivePresentation

MySlideArray = Array(2, 3, 4, 5, 6, 7, 8)

MyChartArray = Array(Sheet2.ChartObjects("A-01"), Sheet2.ChartObjects("A- 
02"), Sheet2.ChartObjects("A-04"), Sheet2.ChartObjects("A-07"), 
Sheet2.ChartObjects("A-08"), Sheet1.ChartObjects("V-02"), 
Sheet1.ChartObjects("V-01"))

For X = LBound(MySlideArray) To UBound(MySlideArray)
MyChartArray(X).Copy

On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(X)).Shapes.Paste
Error GoTo 0

With myPresentation.PageSetup
On Error Resume Next
shp.LinkFormat.BreakLink
End With

Next X

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False

ThisWorkbook.Activate
MsgBox "Export to PowerPoint complete. Note: **All slides will be lost when 
this workbook is closed.**"

End Sub

0 个答案:

没有答案