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

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

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

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

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

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

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

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

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

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

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自動新增”，即可獲贈檔案，同時可以可以添加我私人微信，可以加群，一起學習：