Note: The other languages of the website are Google-translated. Back to English

Як експортувати окремі або всі діаграми з аркушів 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 Потім натисніть Insert > Модулі.

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 Sub

6 Натисніть кнопку F5 клавішу або натисніть кнопку Виконати, щоб запустити код. Потім буде відкрито новий PowerPoint із вибраною діаграмою або всіма імпортованими діаграмами. І ви отримаєте Kutools для Excel діалоговому вікні, як показано на знімку екрана, клацніть на OK кнопки.


Статті по темі:


Найкращі інструменти для підвищення продуктивності офісу

Kutools для Excel вирішує більшість ваших проблем і збільшує продуктивність на 80%

  • Повторне використання: Швидко вставте складні формули, діаграми і все, що ви використовували раніше; Шифрувати комірки з паролем; Створити список розсилки та надсилати електронні листи ...
  • Супер формула бар (легко редагувати кілька рядків тексту та формули); Макет читання (легко читати та редагувати велику кількість комірок); Вставте у відфільтрований діапазон...
  • Об’єднати клітинки / рядки / стовпці без втрати даних; Вміст розділених комірок; Об'єднати повторювані рядки / стовпці... Запобігання дублюючим клітинам; Порівняйте діапазони...
  • Виберіть Повторюваний або Унікальний Рядки; Виберіть Пусті рядки (усі клітинки порожні); Супер знахідка та нечітка знахідка у багатьох робочих зошитах; Випадковий вибір ...
  • Точна копія Кілька клітинок без зміни посилання на формулу; Автоматичне створення посилань на кілька аркушів; Вставте кулі, Прапорці та інше ...
  • Витяг тексту, Додати текст, Видалити за позицією, Видаліть пробіл; Створення та друк проміжних підсумків підкачки; Перетворення вмісту комірок та коментарів...
  • Супер фільтр (зберегти та застосувати схеми фільтрів до інших аркушів); Розширене сортування за місяцем / тижнем / днем, частотою та іншим; Спеціальний фільтр жирним, курсивом ...
  • Поєднайте робочі зошити та робочі аркуші; Об’єднати таблиці на основі ключових стовпців; Розділіть дані на кілька аркушів; Пакетне перетворення xls, xlsx та PDF...
  • Понад 300 потужних функцій. Підтримує Office / Excel 2007-2019 та 365. Підтримує всі мови. Простота розгортання на вашому підприємстві чи в організації. Повна функція 30-денної безкоштовної пробної версії. 60-денна гарантія повернення грошей.
вкладка kte 201905

Вкладка Office забезпечує інтерфейс з вкладками для Office і значно спрощує вашу роботу

  • Увімкніть редагування та читання на вкладках у Word, Excel, PowerPoint, Publisher, Access, Visio та Project.
  • Відкривайте та створюйте кілька документів на нових вкладках того самого вікна, а не в нових вікнах.
  • Збільшує вашу продуктивність на 50% та зменшує сотні клацань миші для вас щодня!
дно офісної таблиці
Коментарі (7)
Поки немає оцінок. Оцініть першим!
Цей коментар був мінімізований модератором на сайті
Дякую, ваш код ідеально спрацював для того, що мені потрібно було зробити. Я додам вашу сторінку в закладки і повернуся, коли мені знадобиться більше.
Цей коментар був мінімізований модератором на сайті
Привіт, дякую за код.

Я намагався оновити ваш код з невеликими змінами, але я не знаю, як це зробити, мені потрібно оновити/змінити деякі форми на певному слайді, але я не знаю, як це зробити.?
Цей коментар був мінімізований модератором на сайті
Привіт Антоні,
На жаль, поки що не можу вам допомогти. Дякую за коментар.
Цей коментар був мінімізований модератором на сайті
Здравствуйте,
Як я можу отримати деякі речі в PDF?

Дякую !
Цей коментар був мінімізований модератором на сайті
привіт,

Я спробував запустити ваш код, але, хоча він видає мені це повідомлення, він не відкриває жодного PowerPoint без жодної помилки.
Діаграми мають бути на єдиному аркуші, чи немає проблем, якщо вони будуть на аркуші разом?

Завдяки.
Цей коментар був мінімізований модератором на сайті
Привіт, Андреас,
Ви можете експортувати одну діаграму, вибравши її та запустивши перший код.
Або експортуйте всі діаграми в книзі з другим кодом.
Дякуємо за ваш коментар.
Цей коментар був мінімізований модератором на сайті
Привіт, ваш код дуже схожий на той, який я зробив, але у мене є запитання, як я можу вставити графіку, але я можу редагувати дані у файлі Power Point?
There are no comments posted here yet
Залишайте свої коментарі
Публікація як гість
×
Оцініть цю публікацію:
0   Персонажі
Рекомендовані місця