Как да експортирате една или всички диаграми от работни листове на Excel в PowerPoint?
Понякога може да се наложи да експортирате диаграма или всички диаграми от Excel в PowerPoint за някаква цел. Тази статия говори за това как да го постигнете.
Експортирайте една диаграма или всички диаграми от работен лист на Excel в PowerPoint с VBA код
Експортирайте една диаграма или всички диаграми от работен лист на Excel в PowerPoint с VBA код
Този раздел ще представи VBA кодове за експортиране на една диаграма или всички диаграми от работна книга в PowerPoint. Моля, направете следното.
1. Натисни Друг + F11 ключове заедно, за да отворите Microsoft Visual Basic за приложения прозорец.
2. В Microsoft Visual Basic за приложения прозорец, кликнете Инструменти > Препратки както е показано на екранната снимка по-долу.
3. В Препратки – VBAProject диалогов прозорец, превъртете надолу, за да намерите и маркирате Библиотека с обекти на Microsoft PowerPoint опция и след това щракнете върху OK бутон. Вижте екранна снимка:
4. След това кликнете Поставете > Модули.
5. Ако искате да експортирате една диаграма в PowerPoint, моля, изберете диаграмата в работния лист, след което се върнете към Microsoft Visual Basic за приложения прозорец, копирайте и поставете кода на 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 Sub6. Натисни F5 или щракнете върху бутона Изпълнение, за да изпълните кода. След това ще се отвори нов PowerPoint с избраната диаграма или всички импортирани диаграми. И ще получите а Kutools за Excel диалоговия прозорец, както е показано на екранната снимка по-долу, моля, щракнете върху OK бутон.
Още по темата:
- Как да запишете, експортирате множество/всички листове в отделни csv или текстови файлове в Excel?
- Как да запазя селекция или цяла работна книга като PDF в Excel?
Най-добрите инструменти за продуктивност в офиса
Усъвършенствайте уменията си за Excel с Kutools за Excel и изпитайте ефективност, както никога досега. Kutools за Excel предлага над 300 разширени функции за повишаване на производителността и спестяване на време. Щракнете тук, за да получите функцията, от която се нуждаете най-много...
Раздел Office Внася интерфейс с раздели в Office и прави работата ви много по-лесна
- Разрешете редактиране и четене с раздели в Word, Excel, PowerPoint, Publisher, Access, Visio и Project.
- Отваряйте и създавайте множество документи в нови раздели на един и същ прозорец, а не в нови прозорци.
- Увеличава вашата производителност с 50% и намалява стотици кликвания на мишката за вас всеки ден!
