将循环内的一系列单元格复制到 Powerpoint

Question

我有一个数据集，我正在尝试将其转换为自动 PowerPoint slides.The 行数每周更改一次，因此范围必须可变。 this is how my data looks like

到目前为止，我已经能够为每个标题创建一张幻灯片，将 headers 复制为图像并将第 16 个单元格的值复制到每张幻灯片，但现在我想复制每行的值作为图像循环，但仅从 B 列到 O 列。这样第一张幻灯片就会有 (B1:O1) 第二个会有 (B2:O2) 但我还没有想出如何去做。我想使用“rowShape”作为行图像的名称到目前为止，这是我的代码：

Option Explicit
Sub Data_to_PowerPoint()

    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim ExcelRow As Range
    Dim CellRange As Range
    Dim SlideText As Variant
    Dim lr As Long
    Dim hdr As Range
    Dim myShape As Object
    Dim rowShape As Object

    'The first range of cells in the table.
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    Set CellRange = Sheets("TicketSummary").Range("A1:A" & lr)

    'Determine header range.
    Set hdr = Sheets("TicketSummary").Range("B1:O1")

    'Look for existing powerpoint instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    'Create a PowerPoint
    If newPowerPoint Is Nothing Then

        Set newPowerPoint = New PowerPoint.Application

    End If

    'Setup the presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then

        newPowerPoint.Presentations.Add

    End If

    'Make PowerPoint visible
    newPowerPoint.Visible = True

    'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each ExcelRow In CellRange



        'Add a new slide
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

        'Create the body text for the slide
        SlideText = Cells(ExcelRow.Row, 16)

        'Input the title of the slide
        activeSlide.Shapes(1).TextFrame.TextRange.Text = ExcelRow.Value

        'Input the body text for the slide
        activeSlide.Shapes(2).TextFrame.TextRange.Text = SlideText
        
        
        'Copy Header.
         hdr.Copy
         
        'Paste header to PowerPoint and position
        activeSlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
        Set myShape = activeSlide.Shapes(activeSlide.Shapes.Count)
  
       'Set position:
        myShape.Left = 60
        myShape.Top = 152
      
   Next

   Set activeSlide = Nothing
   Set newPowerPoint = Nothing

End Sub

Answer 1

Option Explicit

Sub Data_to_PowerPoint()

    Dim pp As PowerPoint.Application, pps As PowerPoint.Slide
    Dim lr As Long, i As Long, n As Long
    
    'Look for existing powerpoint instance
    On Error Resume Next
    Set pp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    'Create a PowerPoint
    If pp Is Nothing Then
        Set pp = New PowerPoint.Application
    End If
    'Setup the presentation in PowerPoint
    If pp.Presentations.Count = 0 Then
        pp.Presentations.Add
    End If
     'Make PowerPoint visible
    pp.Visible = True
    
    'The first range of cells in the table.
    With Sheets("TicketSummary")
     
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To lr
            ' create slide
            pp.ActivePresentation.Slides.Add i - 1, ppLayoutText
            pp.ActiveWindow.View.GotoSlide i - 1
            Set pps = pp.ActivePresentation.Slides(i - 1)

           'Input the title of the slide
            pps.Shapes(1).TextFrame.TextRange.Text = .Cells(i, "A")
            
            'Input the body text for the slide
            pps.Shapes(2).TextFrame.TextRange.Text = .Cells(i, "P") ' col 16
            
            ' copy header
            ' Paste to PowerPoint and position
            ' paste 2 = ppPasteEnhancedMetafile 3 ppPasteMetafilePicture
            n = pps.Shapes.Count
            .Range("B1:O1").Copy
            Application.Wait Now + TimeSerial(0, 0, 1) ' 1 second wait
            pps.Shapes.PasteSpecial DataType:=2
            
            ' wait for shape to be pasted
            Do
                DoEvents
            Loop Until pps.Shapes.Count > n
            Application.CutCopyMode = False
            
            'Set position:
            With pps.Shapes(n + 1)
                .Left = 60
                .Top = 182
            End With
            
            ' copy row
            n = pps.Shapes.Count
            .Range("B1:O1").Offset(i - 1).Copy
            Application.Wait Now + TimeSerial(0, 0, 1) ' 1 second wait
            pps.Shapes.PasteSpecial DataType:=2
            
            ' wait for shape to be pasted
            Do
                DoEvents
            Loop Until pps.Shapes.Count > n
            Application.CutCopyMode = False
            
            'Set position:
            With pps.Shapes(n + 1)
                .Left = 60
                .Top = 202
            End With
              
        Next
    End With
    MsgBox lr - 1 & " slides created"
    
End Sub

将循环内的一系列单元格复制到 Powerpoint

Copy a range of Cells inside a loop to Powerpoint

excel

vba

loops

powerpoint