天天看點

Excel工作表資料批量制作PPT,您隻需10秒制作1000頁PPT,其實很簡單

我們大部分人制作PPT的時候正常操作步驟如下:

1、先打開Microsoft PowerPoint ,打開後點選菜單欄中的設計,出現下面的主題,選擇一款預定好的主題新增空白文檔。

2、然後添加上主題标題文字。

3、右擊左面的預覽幻燈片空白部分,點選建立幻燈片。

4、出現之後按照原本的PPT闆式添加産品介紹文檔,點選就繼續新增,儲存後PPT文檔就開始制作。

今天要給大家分享的是,如何花費10秒批量制作1000頁PPT,給大家釋放工作壓力,增加工作效率:

Step01-原始資料如下,當然我們可以增加行,有多少行就有多少頁PPT,這是自動新增,同學們可以自行增加:

Excel工作表資料批量制作PPT,您隻需10秒制作1000頁PPT,其實很簡單

Step-02 點選執行按鍵,即可自動新增PPT檔案,大概3秒完成100頁新增,這個速度由于電腦組態不同,導緻新增的速度不一緻;

Excel工作表資料批量制作PPT,您隻需10秒制作1000頁PPT,其實很簡單

Step-03 ,執行完成後的效果如下,有興趣的同學可以獲得源檔案,自行測試效果;

Excel工作表資料批量制作PPT,您隻需10秒制作1000頁PPT,其實很簡單

Step-04 代碼分為2部分,一部分是新增PPT檔案,一部分複制資料到PPT,便于同學們了解:

新增PPT 檔案代碼:

Sub 新增PPT()
    Set s = CreateObject("powerPoint.application")
    Set pp = s.Presentations.Add
    pp.SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & ".ppt"
    pp.Close
    s.Quit
End Sub      

複制資料PPT 檔案代碼:​

Sub Excel微信公衆号()
    Dim ws As Worksheet
    Dim pptApp As PowerPoint.Application
    Dim pptPrs As PowerPoint.Presentation
    Dim i As Long
    Dim myppt As String
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Call 新增PPT
    myppt = ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & ".ppt"
    Set ws = Worksheets(1)
    k = ws.Cells(Rows.Count, 1).End(3).Row - 1
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPrs = pptApp.Presentations.Add
    With pptPrs
        For i = 1 To k
            With .Slides.Add(Index:=i, Layout:=ppLayoutText).Shapes
                .Title.TextFrame.TextRange = ws.Cells(i + 1, 1).Text   '添加标題
                .Range(2).TextFrame.TextRange = ws.Cells(i + 1, 2).Text _
                    & vbCrLf & ws.Cells(i + 1, 3).Text _
                    & vbCrLf & ws.Cells(i + 1, 4).Text _
                    & vbCrLf & ws.Cells(i + 1, 5).Text _
                    & vbCrLf & ws.Cells(i + 1, 6).Text _
                    & vbCrLf & ws.Cells(i + 1, 7).Text _
                    & vbCrLf & ws.Cells(i + 1, 8).Text _
                    & vbCrLf & ws.Cells(i + 1, 9).Text _
                    & vbCrLf & ws.Cells(i + 1, 10).Text _
                    & vbCrLf & ws.Cells(i + 1, 11).Text _
                    & vbCrLf & ws.Cells(i + 1, 12).Text        '添加正文
            End With
        Next i
        .SaveAs myppt
'        .Close         '設定此語句可關閉建立的文檔
    End With
'    pptApp.Quit       '設定此語句可關閉PowerPoint應用程式


    Set ws = Nothing
    Set pptPrs = Nothing
    Set pptApp = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub      

Step-04 獲得源檔案,可以在微信公衆号背景私信“PPT自動新增”,即可獲贈檔案,同時可以可以添加我私人微信,可以加群,一起學習: