复制 PPT 中嵌入的 Excel OLE 对象

Question

我正在尝试在 PPT 中使用 VBA 打开/编辑嵌入的 OLE Excel 对象，复制选定的单元格，然后将它们粘贴回同一张幻灯片中。这可能吗？我已经开始打开并编辑 ole 对象，但不知道如何复制已选择的单元格。它需要是已选择的单元格，因为数据引用不一致，因此不能使用静态单元格/工作表引用。到目前为止我的代码见下文。

Dim slide As Object
Dim shape As Object
For Each slide In ActivePresentation.Slides
    For Each shape In slide.Shapes
        If shape.Type = msoEmbeddedOLEObject Then
            If InStr(shape.OLEFormat.ProgID, "Excel.Sheet") > 0 Then
                shape.OLEFormat.DoVerb (1) 
                '''shape.OLEFormat.Object.Worksheets(1).Range("A1:F20").Copy
                '''The above line works but I need the data reference to be dynamic.
            End If
        End If
    Next
Next

样本文件： https://github.com/semajkim/Extract_PPT_Data/blob/c64c2aebe13eaa81501c35d20a3553281fc187c0/Example_PPT.pptm

Answer 1

注意：无需打开工作簿。

Range.CurrentRegion 将为您提供动态范围。

Shape.OLEFormat.Object.Worksheets(1).Range("A1").CurrentRegion.Copy

设置对 Microsoft Excel xx.x 对象库 的引用。这将允许您输入变量，从而启用智能感知。

Sub PasteRange()
    Dim Slide As Slide
    Dim Shape As Shape
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
        
    For Each Shape In ShapesWithWorkbooks
        Set Slide = Shape.Parent
        Set wb = Shape.OLEFormat.Object
            
        For Each ws In wb.Worksheets
            ws.UsedRange.Copy
            Shape.Parent.Shapes.Paste
        Next
    Next
End Sub


Sub PrintWorkbooksWorksheetsUsedRanges()
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    For Each wb In ExtractExcelWorkbooks
        For Each ws In wb.Worksheets
            Debug.Print wb.Name, ws.Name, ws.UsedRange.Address
        Next
    Next
End Sub
    
Function ExtractExcelWorkbooks() As Collection
    Dim Map As New Collection
    Dim Slide As Slide
    Dim Shape As Shape
    For Each Slide In ActivePresentation.Slides
        For Each Shape In Slide.Shapes
            If Shape.Type = msoEmbeddedOLEObject Then
                If InStr(Shape.OLEFormat.ProgID, "Excel.Sheet") > 0 Then
                    Map.Add Shape.OLEFormat.Object
                End If
            End If
        Next
    Next
    Set ExtractExcelWorkbooks = Map
End Function

Sub PrintSlidesShapesWorkbooksWorksheetsUsedRanges()
    Dim Slide As Slide
    Dim Shape As Shape
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    
    For Each Shape In ShapesWithWorkbooks
        Set Slide = Shape.Parent
        Set wb = Shape.OLEFormat.Object
        
        For Each ws In wb.Worksheets
            Debug.Print Slide.Name, Shape.Name, wb.Name, ws.Name, ws.UsedRange.Address
        Next
    Next
End Sub

Function ShapesWithWorkbooks() As Collection
    Dim Map As New Collection
    Dim Slide As Slide
    Dim Shape As Shape
    For Each Slide In ActivePresentation.Slides
        For Each Shape In Slide.Shapes
            If Shape.Type = msoEmbeddedOLEObject Then
                If InStr(Shape.OLEFormat.ProgID, "Excel.Sheet") > 0 Then
                    Map.Add Shape
                End If
            End If
        Next
    Next
    Set ShapesWithWorkbooks = Map
End Function