VBA实用小程序：将Excel中的内容输入到PowerPoint
VBA实用小程序：将Excel中的内容输入到PowerPoint
在将Excel中的内容输入到Word中时，可以利用Word的书签功能，而将Excel中的内容输入到Powerpoint要困难得多，因为它没有书签，甚至不允许为幻灯片上的对象命名，那么，怎么办呢？可以在代码中对其进行寻址。
无论何种情，我都想要一些简单的东西，任何人都可以在没有技术知识的情况下进行设置。因此，下面的代码的思路很简单，对其进行设置，只需为Excel中的文本、区域和图表命名，并按照代码中的说明在Powerpoint中创建匹配的名称。
注意，代码也有局限，不能保证在所有情况下都能正常工作。
完整的代码如下：
'这段代码将图表和表复制到PowerPoint文档,替换现有对象
Dim PPTApp As Object 'pres.Application
Dim pres As Object 'pres.Document
Dim t
Sub ShowInstructions()
'要复制的工作表,根据实际情况修改
ThisWorkbook.Sheets("Merge Instructions").Copy
End Sub
'主程序
Public Sub MergeToPowerpoint()
Application.ScreenUpdating = False
t = Timer
'打开PPT
Set PPTApp = Nothing
Set pres= Nothing
On Error Resume Next
Set PPTApp = GetObject(, "Powerpoint.Application")
If Err<> 0 Then
MsgBox "检查Powerpoint演示是打开的"
Exit Sub
End If
'获取活动文档
Set pres= PPTApp.ActivePresentation
If Err<> 0 Then
MsgBox "连接到当前PowerPoint演示错误: " &Err.Message
Exit Sub
End If
On Error GoTo 0
'处理表和图表
'在PPT中查找所有相关标签并处理它们
Dim slide As Object
Dim shpPPT As Object
Dim sht As Worksheet, cht As ChartObject
Dim r As Range, shpXL As Shape, tag As String, found As Boolean, errorCount As Long
Dim C As New Collection, i As Long
For Each slide In pres.Slides
Do While C.Count > 0: C.Remove 1: Loop
For Each shpPPT In slide.Shapes
C.Add shpPPT, shpPPT.Name
Next
Retry:
For i= 1 To C.Count
tag = C(i).AlternativeText
If InStr(1, tag, "tag_", vbTextCompare) = 1 Then
'Debug.Print tag & ": ";
tag = Mid$(tag, 5)
found = False
On Error Resume Next
Range(tag).Copy
If Err.Number = 0 Then found = True
On Error GoTo 0
If Not found Then
For Each sht In ThisWorkbook.Sheets
For Each shpXL In sht.Shapes
If shpXL.Name = tag Then
shpXL.Copy
found = True
Exit For
End If
Next shpXL
If found Then Exit For
Next sht
If Not found Then
For Each sht In ThisWorkbook.Sheets
For Each cht In ActiveSheet.ChartObjects
If cht.Name =tag Then
cht.CopyPictureFormat:=xlPicture
found =True
Exit For
End If
Next cht
If found Then Exit For
Next sht
End If
End If
If found Then
On Error Resume Next
With slide.Shapes.PasteSpecial(DataType:=2, DisplayAsIcon:=0)
If Err <> 0 Then
If errorCount <5 Then
errorCount =errorCount + 1
'Beep
Debug.Print"错误 =" & errorCount
GoTo Retry
Else
MsgBox "有错误. 请重试.",vbCritical
Exit Sub
End If
End If
On Error GoTo 0
.Top = C(i).Top
.Left = C(i).Left
.Width = C(i).Width
.Height = C(i).Height
C(i).Delete
.AlternativeText ="tag_" & tag
End With
Else
Debug.Print "没有找到."
End If
End If
Next i
Next slide
'激活PPT,便于用户核查结果
PPTApp.Activate
Set PPTApp = Nothing
Application.CutCopyMode = False
Cells(1,1).Select
Application.StatusBar = False
t = Timer- t
End Sub
注：本代码整理自www.mrexcel.com，供学习参考。