通过 Excel VBA 将大表格粘贴到单独的幻灯片中

Question

我想使用 VBA 将表格从 excel 粘贴到 power point。但是，由于我有动态范围，因此我想创建 15 行的幻灯片，以便更好地可视化。例如，它将第 1 行到第 15 行粘贴到第 1 号幻灯片中，然后粘贴到第 1 行，将第 16 行到第 29 行粘贴到第 2 号幻灯片中，依此类推。这里第 1 行是表的标题。我附上了我只能创建一张幻灯片的代码。如果有人可以帮助我，我将不胜感激。

Sub SortingandSlidecreation()

    Dim pptName As String
    Dim ppt As PowerPoint.Application
    Dim myPres As PowerPoint.Presentation
    Dim slds As PowerPoint.Slides
    Dim sld As PowerPoint.slide
    Dim pptextbox As PowerPoint.Shape
    Dim oLayout As CustomLayout
    Dim wb As Workbook
    Dim ws As Worksheet

    Dim y As Workbook, LastRow&
    Dim r As Range


    Set wb = ThisWorkbook
    Set ws = wb.Sheets("SortedTable")

    'This will open a PowerPoint template (I didn't attach the function) 
    pptName = openDialog()                                              
    Set ppt = CreateObject("PowerPoint.Application")
    Set myPres = ppt.Presentations.Open(pptName)
    Set slds = myPres.Slides

    ' creating slides at the end of the template 
    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)

    'Here data is selected for pasting
    Set r = ThisWorkbook.Worksheets("SortedTable").Range("A1:L" & LastRow)
    r.Copy
    sld.Shapes.PasteSpecial DataType:=0
    sld.Shapes(1).Top = 100
    sld.Shapes(1).Left = 100

    'Here title of the table is added
    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Summary of Current Projects"  
        .TextRange.Font.Bold = msoTrue
        .TextRange.Font.Name = "Arial(Headings)"
        .TextRange.Font.Size = 20
        .TextRange.Font.Color.RGB = RGB(0, 51, 102)
    End With

End Sub

Answer 1

删除您当前对LastRow 的定义。然后删除 Set slds = myPres.Slides 行之后的所有内容并粘贴此代码。

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") 'Header Row
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

    'Here title of the table is added
    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Summary of Current Projects"  
        .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