时间戳

首页 > 解决方案 > 我想使用 VBA 将复制的单元格块从 Excel 粘贴到 PPT 演示文稿中的图表数据中

excel - 我想使用 VBA 将复制的单元格块从 Excel 粘贴到 PPT 演示文稿中的图表数据中

问题描述

我正在通过 Excel 编写一个宏，它将帮助我执行以下步骤。目前，我被困在第 3 步。

  1. '在Excel工作表中复制特定单元格
  2. '打开现有的 Powerpoint 演示文稿（存在四张幻灯片，每张幻灯片上大约有 6-7 个图表，其基础数据必须用复制的单元格块替换）
  3. '选择幻灯片 1 上的特定图表
  4. '通过右键单击“编辑数据”打开特定图表的基础数据
  5. 在弹出的工作表中选择单元格块，并将其替换为在步骤 1 中从 Excel 复制的数据

我目前的问题在于第 3 步，我无法在 PowerPoint 中选择任何图表。我也很感激所有可以帮助我完成第 4 步和第 5 步的指导。

我当前的代码如下所示： 


Sub MyMacroRätt()

'Marks and copies a cell block in my Excel file 

    ActiveSheet.Range("R55", "T75").Select
    Selection.Copy

'Open an existing PowerPoint file 

        Dim PPT As PowerPoint.Application
        Set PPT = New PowerPoint.Application
        PPT.Visible = True
        PPT.Presentations.Open Filename:="C:\Users\seleveafe\Desktop\XXXXXX.pptm"

        Dim PPPres As PowerPoint.Presentation
        Set PPPres = PPT.ActivePresentation
        Dim pslide As PowerPoint.Slide
        Dim pchart As PowerPoint.Chart

'Mark the first chart on the first slide 
        With ActiveWindow.Selection.ShapeRange(1)

            If .HasChart = True Then

'Open Edit Data-sheet for selected chart 
        Chart.ActivateChartDataWindow

        End If
        End With

'Select existing data i Edit Data-sheet and replace with copied data from Excel 

End Sub

标签： excelvbachartspowerpoint

解决方案

下面的宏打开指定的 PowerPoint 文件，激活 ChartData 以便打开其工作簿，将指定的数据复制到工作簿的第一个工作表中，从 A2 开始，然后将其关闭。您需要相应地更改目标单元格 (A2)。

Option Explicit

Sub MyMacroRätt()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptShape As PowerPoint.Shape
    Dim rngCopyFrom As Range

    Set rngCopyFrom = ActiveSheet.Range("R55", "T75")

    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True

    Set pptPres = pptApp.Presentations.Open(Filename:="C:\Users\seleveafe\Desktop\XXXXXX.pptm")

    With pptPres.Slides(1) 'first slide
        For Each pptShape In .Shapes
            If pptShape.HasChart Then 'first chart
                Exit For
            End If
        Next pptShape
        If Not pptShape Is Nothing Then
            pptShape.Chart.ChartData.Activate
            With rngCopyFrom
                pptShape.Chart.ChartData.Workbook.Worksheets(1).Range("a2") _
                    .Resize(.Rows.Count, .Columns.Count).Value = .Value
            End With
            pptShape.Chart.ChartData.Workbook.Close
        End If
    End With

    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptShape = Nothing
    Set rngCopyFrom = Nothing

End Sub

编辑

要选择要更新的图表，例如第二个图表，请尝试以下操作...

Option Explicit

Sub MyMacroRätt()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptShape As PowerPoint.Shape
    Dim rngCopyFrom As Range
    Dim ChartNum As Long
    Dim ChartIndex As Long

    ChartNum = 2 'second chart

    Set rngCopyFrom = ActiveSheet.Range("R55", "T75")

    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True

    Set pptPres = pptApp.Presentations.Open(Filename:="C:\Users\seleveafe\Desktop\XXXXXX.pptm")

    With pptPres.Slides(1) 'first slide
        ChartIndex = 0
        For Each pptShape In .Shapes
            If pptShape.HasChart Then
                ChartIndex = ChartIndex + 1
                If ChartIndex = ChartNum Then
                    Exit For
                End If
            End If
        Next pptShape
        If Not pptShape Is Nothing Then
            pptShape.Chart.ChartData.Activate
            With rngCopyFrom
                pptShape.Chart.ChartData.Workbook.Worksheets(1).Range("a2") _
                    .Resize(.Rows.Count, .Columns.Count).Value = .Value
            End With
            pptShape.Chart.ChartData.Workbook.Close
        End If
    End With

    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptShape = Nothing
    Set rngCopyFrom = Nothing

End Sub

推荐阅读