Question

我想使用VBA将表格从Excel粘贴到Power Point。但是，由于我具有动态范围，因此我只想创建具有15行的幻灯片，以实现更好的可视化效果。例如，它将第1行到第15行粘贴到第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

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

1 个答案: