☰

如何使用 vba 将大型 Excel 表粘贴到多张幻灯片中？

tag-icon • tag-icon microsoft-excel vba microsoft-powerpoint
如何使用 vba 将大型 Excel 表粘贴到多张幻灯片中？

我是这个论坛的新手，也是 VBA 的新手。我正在处理一个非常大的 Excel 表（超过 200 行），其中我添加了一个代码，根据其中一列的值何时发生变化来识别分页符。我已经想出了如何将我的数据范围粘贴到 PowerPoint 幻灯片中，但我需要根据分页符的设置位置/时间将其粘贴到单独的幻灯片上。

这是我的分页符代码：

J = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
For I = J To 2 Step -1
    If Range("I" & I).Value <> Range("I" & I - 1).Value Then
        ActiveSheet.HPageBreaks.Add Before:=Range("I" & I)
    End If
Next I

这是我目前将范围放入 PowerPoint 中的内容，但这会将所有内容粘贴到一张幻灯片上：

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:J5")

'Create an Instance of PowerPoint
  On Error Resume Next

'Is PowerPoint already opened?
  Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
  Err.Clear

'If PowerPoint is not already open then open PowerPoint
  If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
  If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
  End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile



Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange

'Center Object
  With myPresentation.PageSetup
    shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
    shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)


'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

  End With

答案1

您可以使用此 VBA 代码，将每 15 行（作为页面）粘贴到新幻灯片中。

Private Sub Multipage_Slide()

Dim LastRow as Long, i as Long, j as Integer, _   

rngH as Range, wss as Worksheet

LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

Set rngH = ws.Range("A1:L1") 
i = 2

Set wss = wb.Worksheets.Add

Do While i <= LastRow
    j = Application.Min(i + 13, LastRow)
    Union(rngH, ws.Range("A" & i, ws.Range("L" & j))).Copy Destination:= wss.Range("A1")

    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
    wss.Range("A1:L" & j-i+2).Copy

    sld.Shapes.PasteSpecial DataType:=0
    sld.Shapes(1).Top = 100
    sld.Shapes(1).Left = 100


    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Multiple Slides"  
        .TextRange.Font.Bold = msoTrue
        .TextRange.Font.Name = "Arial(Headings)"
        .TextRange.Font.Size = 20
        .TextRange.Font.Color.RGB = RGB(0, 51, 102)
    End With
    i = j + 1
Loop

Application.DisplayAlerts = False
wss.Delete
Application.DisplayAlerts = True
Set wss = Nothing

End Sub

注意：

  • A1:L1是标题，您可以调整它。
  • 最后一行的值Application.Min(i + 13, LastRow)，可以调整（目前选择15行）。
  • 字体名称、颜色和大小也可以编辑。

相关内容