如何将单元格区域作为表格从 Excel 复制到 PowerPoint - VBA

Posted

技术标签:

【中文标题】如何将单元格区域作为表格从 Excel 复制到 PowerPoint - VBA【英文标题】:How to copy cell range as table from Excel to PowerPoint - VBA 【发布时间】:2011-04-19 21:58:15 【问题描述】:

我找不到任何方法来做到这一点。我现在拥有的是它将范围复制为图像:

Dim XLApp As Excel.Application 
Dim PPSlide As Slide 

Set XLApp = GetObject(, "Excel.Application") 
XLApp.Range("A1:B17").Select 
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select

这就像一个魅力,但是否有可能让它将范围复制为表格而不是图片?

【问题讨论】:

为什么同一个问题要问两次? 很抱歉,我无法使用发布最后一个问题的帐户登录,并且标记混乱。所以我认为最好用格式正确的代码再次询问。 【参考方案1】:

好吧,如果我手动复制它,我可能会执行选择性粘贴并选择“格式化文本 (RTF)”作为类型。我相信你可以在 VBA 中模仿它。

编辑

啊,我们开始吧。在您的幻灯片中执行此操作:

    转到插入->对象 选择您的 Excel 文件。检查链接选项。

您的 XL 文件的链接现已嵌入到您的 PP 文件中。当您的 XL 文件中的数据发生变化时,您可以:

    通过右键单击->更新链接手动更新。 VBA 使用类似ActivePresentation.UpdateLinks 的东西自动更新它

这是一种与您最初采用的方法截然不同的方法,但我相信它可以让您更接近您的目标。虽然它有它自己的问题,但这些都是可以解决的。

【讨论】:

我已经尝试过 PPSlide.Selection.PasteExcelTable - 但这不起作用。还有 PPSlide.Shapes.PasteExcelTable 。有任何想法吗?编辑:我无法在 powerpoint 中记录宏,但是当我尝试在 word 中执行并从 excel 中复制表格时,您建议我获取此代码:Selection.PasteAndFormat (wdTableOriginalFormatting) - 我可以在 powerpoint 中使用类似的东西吗vba 代码? 嗯,你为什么不能使用 PasteExcelTable 方法?你得到什么错误? 编译错误:找不到方法或数据成员是我尝试 PPSlide.Selection.PasteExcelTable 或 PPSlide.Shapes.PasteExcelTable 时遇到的错误。所以我猜语法不是很好吗? (一个小提示:VBA 有一个叫做 Intellisense 的功能,它可以为您提供可用方法/属性/等的列表。在 VBA 中,如果您输入“PPSlide”。您应该会看到一个下拉菜单该类成员的列表。如果您没有看到您要查找的内容,那么您做错了。在您设计以前从未做过的事情时非常有用) 见我上面的编辑。另一种方法。【参考方案2】:

这可以简单地完成

Dim XLApp As Excel.Application
Dim PPSlide As Slide

Set XLApp = GetObject(, "Excel.Application")
XLApp.Range("A1:B17").Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse

【讨论】:

你能解释一下吗?我无法让这个宏工作。【参考方案3】:
Sub abc()

j = 2
Sheets("sheet1").Select

ActiveSheet.Range("a1").Select
ActiveSheet.Range("a65536").Select
lastrow = Selection.End(xlUp).Row

'/// column a
ActiveSheet.Range("a3:a" & lastrow).Select

Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$A$3:$A$" & lastrow).AutoFilter Field:=1, Criteria1:="="

Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label1
   End If

    ActiveSheet.Range("a3:a" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy



    'Selection.EntireRow.Select

'    Range(Selection, Selection.End(xlToRight)).Select
    rownum = Selection.Row

'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label1
'    End If

    'Selection.Copy
    Sheets("Sheet2").Select
    'lrow = ActiveSheet.Range("A65536").End(xlUp).Row

    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    ActiveSheet.Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select

    Selection.EntireRow.Delete
     Application.CutCopyMode = False

label1:
 Selection.AutoFilter

'column b///////////


ActiveSheet.Range("a65536").Select
lastrow = Selection.End(xlUp).Row
ActiveSheet.Range("b3:b" & lastrow).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$b$3:$b$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label2
   End If

        ActiveSheet.Range("$b$3:$b$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy

    'Range(Selection, Selection.End(xlToLeft)).Select
    '
   ' Selection.EntireRow.Select

    'Range(Selection, Selection.End(xlToRight)).Select

'    rownum = Selection.Row
'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label2
'    End If

   ' Selection.Copy
    Sheets("Sheet2").Select
    'lrow = ActiveSheet.Range("A65536").End(xlUp).Row

    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    ActiveSheet.Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select

    'Selection.SpecialCells(xlCellTypeVisible).Select

'Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
'
'    Selection.EntireRow.Delete

    ActiveSheet.Range("$b$3:$b$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Application.CutCopyMode = False

label2:
     Selection.AutoFilter

    'column c////////////


    ActiveSheet.Range("c65536").Select
lastrow = Selection.End(xlUp).Row
 ActiveSheet.Range("c3:c" & lastrow).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$c$3:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="SG Plus", _
    Operator:=xlOr, Criteria2:="=Select"

Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label3
   End If

            ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy

    'Range(Selection, Selection.End(xlToRight)).Select
'    Selection.Copy
'    Sheets("Sheet2").Select
'    lrow = activehseet.Range("A65536").End(xlUp).Row
'    ActiveSheet.Range("a" & lrow).Select
'    ActiveSheet.Paste
'    Sheets("Sheet1").Select



'    rownum = Selection.Row
'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label3
'    End If

'    Range("a4:a" & lastrow).Select
'    Range(Selection, Selection.End(xlToRight)).Select
'    Selection.EntireRow.Select
'    Selection.SpecialCells(xlCellTypeVisible).Select


            ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select

    Selection.EntireRow.Delete
        Application.CutCopyMode = False


label3:
 Selection.AutoFilter


'column c again/////////////


    ActiveSheet.Range("c65536").Select
lastrow = Selection.End(xlUp).Row

ActiveSheet.Range("c3:c" & lastrow).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$c$3:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label4
   End If

                ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy



'    rownum = Selection.Row
'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label4
'    End If
'
'    Range(Selection, Selection.End(xlToRight)).Select
'
'        Range("a4:a" & lastrow).Select
'    Range(Selection, Selection.End(xlToRight)).Select
'
'    Selection.EntireRow.Copy
    Sheets("Sheet2").Select
    'lrow = ActiveSheet.Range("A65536").End(xlUp).Row

    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    ActiveSheet.Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select

                    ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select

 '   Selection.SpecialCells(xlCellTypeVisible).Select

    Selection.EntireRow.Delete
        Application.CutCopyMode = False

label4:
    Selection.AutoFilter

'//////////////////////////  over  /////////////////////////////



ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("a" & i).Select
If Range("a" & i).Value = "MidAmerica" Or Range("a" & i).Value = "Northeast" Or Range("a" & i).Value = "Southeast" Or _
Range("a" & i).Value = "West" Then
GoTo cont
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
       Selection.Delete Shift:=xlUp
   End If
cont:
Next i


'/////// column b ///////////

ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("b" & i).Select
If Range("b" & i).Value = "CA" Or Range("b" & i).Value = "AZ" Then
GoTo cont2
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont2:
Next i

'///////////column c //////////

ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("c" & i).Select
If Range("c" & i).Value = "SG" Then
GoTo cont3
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont3:
Next i

'//////////column l/////////////
ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("l" & i).Select
If Range("l" & i).Value <= "01/06/2014" And Range("l" & i).Value >= "01/01/2013" Then
GoTo cont4
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont4:
Next i

'//////////column m/////////////
ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("m" & i).Select
If Range("m" & i).Value = "12/01" Or Range("m" & i).Value = "12/05" Then
GoTo cont5
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row


    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont5:
Next i

'//////////column q and r/////////////
ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("q" & i).Select
If Range("q" & i).Value <> " " And Range("r" & i).Value <> " " And Range("u" & i).Value <> " " _
And Range("z" & i).Value <> " " And Range("aa" & i).Value <> " " And Range("ab" & i).Value <> " " _
And Range("b" & i).Value <> " " And Range("j" & i).Value <> " " Then
GoTo cont6
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont6:
Next i


End Sub

【讨论】:

【参考方案4】:

只需要自己解决这个问题。这是对我有用的特殊粘贴:

XLApp.Selection.Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteDefault

我在这里找到了特殊粘贴选项的完整列表:

http://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba

【讨论】:

【参考方案5】:

上述建议的解决方案对我不起作用,因为 excel 表格继续作为(不可编辑的)图片粘贴到 powerpoint 中。

要在 powerpoint 的命令栏中直接运行 pastespecial 'Keep Source Formatting' 按钮,请运行以下代码:

Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

Microsoft msdn 网站上的更多(但有限)信息:https://msdn.microsoft.com/en-us/library/office/ff862419.aspx

【讨论】:

以上是关于如何将单元格区域作为表格从 Excel 复制到 PowerPoint - VBA的主要内容,如果未能解决你的问题,请参考以下文章

VBA 如何批量将单元格复制到另一个工作表中

Excel表格中筛选如何设置多个条件?

excel合并单元格怎么弄

按键精灵如何把复制的数据写入到excel指定单元格中

如何把一个excel表中的公式粘贴到另一张表上?我用的2007版本的。

在excel中如何用鼠标拖动实现单元格内容的复制与移动