当前位置：theitroad>如何将单元格范围作为表格从 Excel 复制到 PowerPoint - VBA

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

声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow 原文地址: http://stackoverflow.com/questions/3840370/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me): StackOverFlow

提示：将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间：2020-09-08 10:49:54 　来源:igfitidea点击:

How to copy cell range as table from Excel to PowerPoint - VBA

excelvbapowerpoint

提问by iper

I can't find any way to do this. What I have now is that it copy the range as an image:

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

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

this works like a charm, but is it possible to get it to copy the range as a table instead of picture?

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

回答by Simon Cowen

This can be done simply with

这可以简单地完成

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

回答by PowerUser

Well, if I was copying it manually, I would probably do a Paste Special and choose "Formatted Text (RTF)" as the type. I'm sure you can mimic that in VBA.

好吧，如果我手动复制它，我可能会做一个选择性粘贴并选择“格式化文本（RTF）”作为类型。我相信你可以在 VBA 中模仿它。

Edit

编辑

Aah, here we go. Do this in your powerpoint:

啊，我们走了。在你的powerpoint中这样做：

  1. Go to Insert->Object
  2. Choose your Excel file. Check the Linkoption.
  1. 转到插入-> 对象
  2. 选择您的 Excel 文件。检查链接选项。

A link to your XL file is now embedded in your PP file. When the data in your XL file changes, you can:

您的 XL 文件的链接现已嵌入您的 PP 文件中。当 XL 文件中的数据发生更改时，您可以：

  1. Update it manually by Right-Click->Update Link.
  2. Update it automatically by VBA by using something like ActivePresentation.UpdateLinks
  1. 通过Right-Click->Update Link手动更新它。
  2. 通过使用类似的东西由 VBA 自动更新它 ActivePresentation.UpdateLinks

This is a very different approach than what you were doing first, but I believe it gets you closer to your goal. It has it own problems, though, but those can be worked out.

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

回答by SDimick

Just needing to figure this out myself. Here's the paste special that worked for me:

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

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

I found the full list of special paste options here:

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

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

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

回答by Floris

The above proposed solutions did not work for me as the excel table continued being pasted in powerpoint as a (non-editable) picture.

上述提出的解决方案对我不起作用，因为 excel 表格继续作为（不可编辑的）图片粘贴在 powerpoint 中。

To directly run the pastespecial 'Keep Source Formatting' button in the commandbar in powerpoint run following code:

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

Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

More (but limited) info on Microsoft msdn site: https://msdn.microsoft.com/en-us/library/office/ff862419.aspx

有关 Microsoft msdn 站点的更多（但有限）信息：https: //msdn.microsoft.com/en-us/library/office/ff862419.aspx

回答by user1934049

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:$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:$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:$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:$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:$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:$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:$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:$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:$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:$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

相关推荐

在 VBA 中查找列的最大值

在 VBA 中查找列的最大值

如何使用 VBA 保护 Excel 工作簿？

如何使用 VBA 保护 Excel 工作簿？

vba 查找黄色文本的所有实例并将字体颜色更改为红色

vba 查找黄色文本的所有实例并将字体颜色更改为红色

循环遍历行和列 Excel 宏 VBA

循环遍历行和列 Excel 宏 VBA

相关推荐
最近更新
标签