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

Question

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

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

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

Pasting a large table into separate slides by Excel VBA

excel

powerpoint

vba