Excel和PPT数据相互转化

zzj824

jiulongpo 发表于 2012-3-29 09:48
汗.........
我是03版的.

那给个03版的附件吧 基于我上面的问题。。。。。。

jiulongpo

zzj824 发表于 2012-3-29 11:55
那给个03版的附件吧 基于我上面的问题。。。。。。

请看下贴.......

jiulongpo

本来开始是用03版的EXCEL写入03的.ppt,但不知为什么,写入图表数据表的数据读不出来,{:soso_e143:}搞了很久,还是不行,只好放弃了.{:soso_e149:}
晚上用excel2007重做了一个excel工作表,写入07版的.PPTX和.PPTM,还是读不出来,真是郁闷{:soso_e109:}.还好,用07版的EXCEL写入03版式的.PPT后顺利读了出来.至此才完成任务.{:soso_e128:}

还请看到此贴的高手进一步完善.{:soso_e163:}

以下是代码,附件在最后------------------------------------------------------------------
'使用前要引用:1. ms PowerPoint 12.0 object
'             2. ms Graph 12.0 object

Function XZwj() As String
Dim Mydz As String
Dim Myfd As FileDialog     '声明一个文件对话框对象
Mydz = ThisWorkbook.Path & "\"     '获得当前工作目录
Set Myfd = Application.FileDialog(msoFileDialogFilePicker)     '设置文件夹选择框对象
With Myfd
    .AllowMultiSelect = False   '只允许选择一个文件
    .Filters.Clear     '清空文件筛选器
    .Filters.Add "PPT文件", "*.ppt", 1     '重新添加文件筛选器
    .InitialFileName = Mydz     '对话框中初始显示的路径
    .Title = "选择一个PPT类型的文件"     '对话框中标题
    .Show     '显示对话框
   
    If .SelectedItems.Count < 1 Then
         XZwj = ""
         Exit Function '没有选择就退出
    End If
   
    XZwj = .SelectedItems(1)     '获得选择后全路径文件夹
End With
End Function

Sub Excel导出到PPt()
Dim Myxzwj As String    '声明变量为字符串
Dim Myppt As PowerPoint.Presentation    '声明变量为PPT演示文稿
Dim Mysli As PowerPoint.Slide    '声明变量为幻灯片
Dim Mysha As PowerPoint.Shape    '声明变量为形状
Dim Mycha As Graph.Chart    '声明变量为图表
Dim Myshe As Worksheet    '声明变量为工作表
Dim Myran    '声明变量为数组
Dim Myro As Long, Myco As Long
Set Myshe = Worksheets("ppt_exc")     '设置对象为工作表
Myshe.Activate     '激活工作表
Myro = Myshe.Range("a65536").End(xlUp).Row     '获得A列最后一个使用单元格的行号
Myco = Myshe.Cells(1, 256).End(xlToLeft).Column     '获得第一行最后一个使用单元格的列号
Myxzwj = XZwj()     '调用函数
If Myxzwj = "" Then     '判断是否选择了文件
    MsgBox "没有选择文件"
    Exit Sub
End If
Set Myppt = GetObject(Myxzwj)     '设置对象为文件中的 ActiveX 对象的引用
For k = Myppt.Slides.Count To 1 Step -1     '在PPT中循环
    Myppt.Slides(k).Delete      '删除全部幻灯片
Next
a = 1     '赋初值
b = 0
For k = 1 To (Myco + 4) / 5     '在工作表列上循环
    If (k - 1) Mod 2 = 0 Then     '一个幻灯片上放2个图表
        Set Mysli = Myppt.Slides.Add(Myppt.Slides.Count + 1, ppLayoutBlank)     '添加新的幻灯片
        b = 0
    End If
   
    Myran = Myshe.Range(Cells(1, a), Cells(1 + 5, a + 4))    '数组赋值
    Set Mysha = Mysli.Shapes.AddOLEObject(Left:=10 + b, Top:=100, Width:=350, Height:=300, _
                ClassName:="MSGraph.Chart", Link:=msoFalse)     '添加新的图表
    b = Mysha.Width + b     '下一张图表的左边距
    Mysha.Name = "Mychart_" & Myshe.Cells(1, a)      '设置图表名称
    Set Mycha = Mysha.OLEFormat.Object     '设置对象
   
    With Mycha
        .HasTitle = True     '图表显示标题
        .ChartTitle.Text = Myran(1, 1)    '设置标题文本
        .HasLegend = False     '图表没有图例
        .ChartType = 65     '图表类型为_数据点折线图
        .Application.PlotBy = 1     '图表产生在行上
        .Parent.DataSheet.Cells.Clear     '清除图表数据表中所有数据
        
        For ro = 1 To UBound(Myran, 1) - 1   '该循环给图表数据表加入数据
            For co = 1 To UBound(Myran, 2)
                .Parent.DataSheet.Cells(ro, co) = Myran(ro + 1, co)   '给图表数据表加入数据
            Next co
        Next ro
    End With
    a = a + 5
Next k
Myppt.Save     'PPT演示文稿保存
Myppt.Close     'PPT演示文稿关闭
Myppt.Application.Quit     'PPT退出
Set Myshe = Nothing     '清空对象
Set Mycha = Nothing
Set Mysha = Nothing
Set Mysli = Nothing
Set Myppt = Nothing     '清空对象
End Sub

Sub PPt导入到Excel()
Dim Myxzwj As String    '声明变量为字符串
Dim Myppt As PowerPoint.Presentation    '声明变量为PPT演示文稿
Dim Mysli As PowerPoint.Slide    '声明变量为幻灯片
Dim Mysha As PowerPoint.Shape    '声明变量为形状
Dim Mycha As Graph.Chart    '声明变量为图表
Dim Myshe As Worksheet    '声明变量为工作表
Dim Myran    '声明变量为数组
Set Myshe = Worksheets("ppt_exc")     '设置对象为工作表
Myshe.Activate     '激活工作表
Myxzwj = XZwj()     '调用函数
If Myxzwj = "" Then     '判断是否选择了文件
    MsgBox "没有选择文件"
    Exit Sub
End If
a = 0     '赋初值
Set Myppt = GetObject(Myxzwj)     '设置对象为文件中的 ActiveX 对象的引用
For Each Mysli In Myppt.Slides     '在幻灯片集合中循环
For Each Mysha In Mysli.Shapes     '在魂状集合中循环
    If Mysha.Type <> msoEmbeddedOLEObject Then     '判断不是图表就退出循环
       Exit For
    End If
   
    Set Mycha = Mysha.OLEFormat.Object     '设置对象
    Myshe.Cells(1, 1 + a) = Mycha.ChartTitle.Text     '标题写入工作表
    For ro = 1 To 5   '该循环把图表数据表写入工作表
    For co = 1 To 5
        Myshe.Cells(ro + 1, co + a) = Mycha.Parent.DataSheet.Cells(ro, co)
    Next co
    Next ro
    a = a + 5
Next Mysha
Next Mysli

Myppt.Close     'PPT演示文稿关闭
Myppt.Application.Quit     'PPT退出
Set Myshe = Nothing     '清空对象
Set Mycha = Nothing
Set Mysha = Nothing
Set Mysli = Nothing
Set Myppt = Nothing     '清空对象
End Sub

ppt_excel.zip (57.96 KB, 下载次数: 373)

2012-3-29 21:36 上传

点击文件名下载附件

终于知道为什么用excel2007做的excel工作表,写入07版的.PPTX和.PPTM,还是读不出来了,在安装 Office 2007 套件 Service Pack 2 之前不能使用 Microsoft Visual Basic 的应用程序 （VBA） 来修改已插入 PowerPoint 2007 或 Word 2007 中的图表
http://support.microsoft.com/kb/948683/zh-cn

zzj824

jiulongpo 发表于 2012-3-29 21:36
本来开始是用03版的EXCEL写入03的.ppt,但不知为什么,写入图表数据表的数据读不出来,搞了很久, ...

你编写的已经很完美了！感动的热泪盈眶，一塌糊涂啊！03和07版的应该不是一个娘亲生的，他们之间难免有隔阂啊！我用10版的可以将excel中的数据导入到ppt中，但是ppt中的数据导入excel中就不行了，我想问万能的帮主一个问题：ppt导入excel中是不是把后半部分的代码要copy到ppt中啊？还是可以直接运用这个代码在excel中直接得到数据？万分感谢！

jiulongpo

zzj824 发表于 2012-3-30 15:45
你编写的已经很完美了！感动的热泪盈眶，一塌糊涂啊！03和07版的应该不是一个娘亲生的，他们之间难免有隔 ...

直接在excel中运行就可以了.
你先运行宏 Sub Excel导出到PPt(),把数据导入ppt中
再把excel中的数据删除,再运行宏 Sub PPt导入到Excel(),就可得到ppt中的数据.

zzj824

jiulongpo 发表于 2012-3-30 20:29
直接在excel中运行就可以了.
你先运行宏 Sub Excel导出到PPt(),把数据导入ppt中
再把excel中的数据删除 ...

帅！经我检验10版的也很实用，就是在把excel导入到ppt中爱死掉，必须关闭后再打开才能看到想要的图表。
我想问一下为什么使用前要引用:1. ms PowerPoint 12.0 object
'             2. ms Graph 12.0 object
这两句话？

jiulongpo

zzj824 发表于 2012-3-31 09:13
帅！经我检验10版的也很实用，就是在把excel导入到ppt中爱死掉，必须关闭后再打开才能看到想要的图表。
...

引用:1. ms PowerPoint 12.0 object,就是为了在EXCEL中可以使用PPT的对象.

引用:2. ms Graph 12.0 object,就是为了在EXCEL中可以使用GRAPH(图表)对象.
以上两种都是显式引用.即直接指定引用类库.
还有隐式引用,即用函数CreateObject () 创建并返回一个对 ActiveX 对象的引用。

zzj824

帮主，菜鸟刚上路，所以问题比较多，想再问你个问题，我怎么能把图表放在当页指定的位置，例如，一个图表放在ppt的正中间，或者放在靠左边的位置，规定上下左右的距离，若是两个以上的，比如，四个图，上面两个下面两个，我要求放在此页靠右下的某个具体位置，并且这四个上下对齐，两两间距一样？先谢谢了…

jiulongpo

你自己修改一下吧.修改红色部份.
一.If (k - 1) Mod 2 = 0 Then     '一个幻灯片上放2个图表
二.这个是在添加图表时,同时设置图表左边距,上边距,宽度,高度
Set Mysha = Mysli.Shapes.AddOLEObject(Left:=10 + b, Top:=100, Width:=350, Height:=300, _
                ClassName:="MSGraph.Chart", Link:=msoFalse)     '添加新的图表

dhabc123

做个记号学习学习。