如何將單個或所有圖表從Excel工作表導出到PowerPoint?
有時,出於某些目的,您可能需要將圖表或所有圖表從Excel導出到PowerPoint。 本文討論的是如何實現它。
使用VBA代碼將單個圖表或所有圖表從Excel工作表導出到PowerPoint
使用VBA代碼將單個圖表或所有圖表從Excel工作表導出到PowerPoint
本節將介紹VBA代碼,以將單個圖表或所有圖表從工作簿導出到PowerPoint。 請執行以下操作。
1。 按 其他 + F11 鑰匙一起打開 Microsoft Visual Basic for Applications 窗口。
2。 在裡面 Microsoft Visual Basic for Applications 窗口中,單擊 工具 > 參考 如下圖所示。
3。 在裡面 參考– VBAProject 對話框中,向下滾動以查找並檢查 Microsoft PowerPoint對像庫 選項,然後單擊 OK 按鈕。 看截圖:
4。 然後點擊 插入 > 模塊.
5.如果要將單個圖表導出到PowerPoint,請轉到在工作表中選擇圖表,然後返回到 Microsoft Visual Basic for Applications 窗口,將下面的VBA代碼複製並粘貼到“模塊”窗口中。
VBA代碼:將單個圖表從Excel工作表導出到PowerPoint
Sub SingleActiveChartToPowerPoint_EarlyBinding1()
'Updated by Extendoffice 2017/9/15
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim pptShpRng As PowerPoint.ShapeRange
Dim xActiveSlideNow As Long
On Error Resume Next
If ActiveChart Is Nothing Then
MsgBox "Select a chart and try again!", vbExclamation, "KuTools For Excel"
Exit Sub
End If
Set pptApp = GetObject(, "PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
Else
If pptApp.Presentations.Count > 0 Then
Set pptPres = pptApp.ActivePresentation
If pptPres.Slides.Count > 0 Then
xActiveSlideNow = pptApp.ActiveWindow.View.Slide.SlideIndex
Set pptSlide = pptPres.Slides(xActiveSlideNow)
Else
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
End If
Else
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
End If
End If
ActiveChart.ChartArea.Copy
With pptSlide
.Shapes.Paste
Set pptShape = .Shapes(.Shapes.Count)
Set pptShpRng = .Shapes.Range(pptShape.Name)
End With
With pptShpRng
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With
pptShpRng.Select
End Sub
如果要從工作簿中導出所有圖表,請複制以下VBA代碼並將其粘貼到“模塊”窗口中。
VBA代碼:將所有圖表從Excel工作表導出到PowerPoint
Option Explicit
'Updated by Extendoffice 2017/9/15
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
Dim xSheet As Worksheet
Dim xChartsCount As Integer
Dim xChart As Object
Dim xActiveSlideNow As Integer
On Error Resume Next
For Each xSheet In ActiveWorkbook.Worksheets
xChartsCount = xChartsCount + xSheet.ChartObjects.Count
Next xSheet
If xChartsCount = 0 Then
MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
Exit Sub
End If
Set pptApp = GetObject(, "PowerPoint.Application")
If pptApp Is Nothing Then
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
Else
If pptApp.Presentations.Count > 0 Then
Set pptPres = pptApp.ActivePresentation
If pptPres.Slides.Count > 0 Then
xActiveSlideNow = pptApp.ActiveWindow.View.Slide.SlideIndex
Set pptSlide = pptPres.Slides(xActiveSlideNow)
Else
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
End If
Else
Set pptPres = pptApp.Presentations.Add
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
End If
End If
For Each xSheet In ActiveWorkbook.Worksheets
For Each xChart In xSheet.ChartObjects
Call pptFormat(xChart.Chart)
Next xChart
Next xSheet
For Each xChart In ActiveWorkbook.Charts
Call pptFormat(xChart)
Next xChart
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "KuTools For Excel"
End Sub
Private Sub pptFormat(xChart As Chart)
Dim xCharTiTle As String
Dim I As Integer
On Error Resume Next
xCharTiTle = xChart.ChartTitle.Text
xChart.ChartArea.Copy
pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
pptSlide.Select
pptSlide.Shapes.PasteSpecial ppPasteJPG
If xCharTiTle <> "" Then
pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
End If
For I = 1 To pptSlide.Shapes.Count
With pptSlide.Shapes(I)
Select Case .Type
Case msoPicture:
.Top = 87.84976
.left = 33.98417
.Height = 422.7964
.Width = 646.5262
Case msoTextBox:
With .TextFrame.TextRange
.ParagraphFormat.Alignment = ppAlignCenter
.Text = xCharTiTle
.Font.Name = "Tahoma (Headings)"
.Font.Size = 28
.Font.Bold = msoTrue
End With
End Select
End With
Next I
End Sub
6。 按 F5 鍵或單擊“運行”按鈕以運行代碼。 然後將打開一個新的PowerPoint,其中包含選定的圖表或所有導入的圖表。 你會得到一個 Excel的Kutools 對話框如下圖所示,請點擊 OK 按鈕。
相關文章:
最佳辦公生產力工具
🤖 | Kutools 人工智慧助手:基於以下內容徹底改變數據分析: 智慧執行 | 生成代碼 | 建立自訂公式 | 分析數據並產生圖表 | 呼叫 Kutools 函數... |
熱門特色: 尋找、突出顯示或識別重複項 | 刪除空白行 | 合併列或儲存格而不遺失數據 | 沒有公式的回合 ... | |
超級查詢: 多條件VLookup | 多值VLookup | 跨多個工作表的 VLookup | 模糊查詢 .... | |
高級下拉列表: 快速建立下拉列表 | 依賴下拉列表 | 多選下拉列表 .... | |
欄目經理: 新增特定數量的列 | 移動列 | 切換隱藏列的可見性狀態 | 比較範圍和列 ... | |
特色功能: 網格焦點 | 設計圖 | 大方程式酒吧 | 工作簿和工作表管理器 | 資源庫 (自動文字) | 日期選擇器 | 合併工作表 | 加密/解密單元格 | 按清單發送電子郵件 | 超級濾鏡 | 特殊過濾器 (過濾粗體/斜體/刪除線...)... | |
前 15 個工具集: 12 文本 工具 (添加文本, 刪除字符,...) | 50+ 圖表 類型 (甘特圖,...) | 40+ 實用 公式 (根據生日計算年齡,...) | 19 插入 工具 (插入二維碼, 從路徑插入圖片,...) | 12 轉化 工具 (數字到單詞, 貨幣兌換,...) | 7 合併與拆分 工具 (高級合併行, 分裂細胞,...) | ... 和更多 |
使用 Kutools for Excel 增強您的 Excel 技能,體驗前所未有的效率。 Kutools for Excel 提供了 300 多種進階功能來提高生產力並節省時間。 點擊此處獲取您最需要的功能...
Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆
- 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,Access,Visio和Project。
- 在同一窗口的新選項卡中而不是在新窗口中打開並創建多個文檔。
- 將您的工作效率提高 50%,每天為您減少數百次鼠標點擊!