我有一個資料集，我試圖將其轉換為自動 PowerPoint 幻燈片。行數每周更改，因此范圍必須是可變的。 這就是我的資料的樣子
到目前為止，我已經能夠為每個標題創建一張幻燈片，將標題復制為影像并將第 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
uj5u.com熱心網友回復：
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/424486.html
上一篇：使用回圈創建一個新陣列，該陣列從另一個陣列中獲取其值，從第二個元素開始并乘以前一個元素
下一篇：R：如何在多列中迭代總和？