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，供学习参考。