Przejdź do głównej zawartości

Jak wyeksportować pojedyncze lub wszystkie wykresy z arkuszy programu Excel do programu PowerPoint?

Czasami w jakimś celu może być konieczne wyeksportowanie wykresu lub wszystkich wykresów z programu Excel do programu PowerPoint. Ten artykuł mówi o tym, jak to osiągnąć.

Eksportuj pojedynczy wykres lub wszystkie wykresy z arkusza programu Excel do programu PowerPoint za pomocą kodu VBA


Eksportuj pojedynczy wykres lub wszystkie wykresy z arkusza programu Excel do programu PowerPoint za pomocą kodu VBA

Ta sekcja przedstawi kody VBA do eksportowania pojedynczego wykresu lub wszystkich wykresów ze skoroszytu do programu PowerPoint. Wykonaj następujące czynności.

1. wciśnij inny + F11 klucze razem, aby otworzyć Microsoft Visual Basic for Applications okno.

2. w Microsoft Visual Basic for Applications okno, kliknij Tools > Referencje jak pokazano na poniższym zrzucie ekranu.

3. w Referencje - VBAProject W oknie dialogowym przewiń w dół, aby znaleźć i zaznaczyć plik Biblioteka obiektów programu Microsoft PowerPoint opcję, a następnie kliknij OK przycisk. Zobacz zrzut ekranu:

4. Następnie kliknij wstawka > Moduł.

5. Jeśli chcesz wyeksportować pojedynczy wykres do programu PowerPoint, przejdź do zaznaczenia wykresu w arkuszu, a następnie wróć do Microsoft Visual Basic for Applications skopiuj i wklej poniższy kod VBA do okna modułu.

Kod VBA: Eksportuj pojedynczy wykres z arkusza programu Excel do programu 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

Jeśli chcesz wyeksportować wszystkie wykresy ze skoroszytu, skopiuj i wklej poniższy kod VBA do okna modułu.

Kod VBA: Eksportuj wszystkie wykresy z arkuszy programu Excel do programu 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. wciśnij F5 lub kliknij przycisk Uruchom, aby uruchomić kod. Następnie zostanie otwarty nowy PowerPoint z wybranym wykresem lub zaimportowanymi wszystkimi wykresami. Otrzymasz plik Kutools dla programu Excel okno dialogowe, jak pokazano na poniższym zrzucie ekranu, kliknij OK przycisk.


Podobne artykuły:

Najlepsze narzędzia biurowe

🤖 Pomocnik AI Kutools: Zrewolucjonizuj analizę danych w oparciu o: Inteligentne wykonanie   |  Wygeneruj kod  |  Twórz niestandardowe formuły  |  Analizuj dane i generuj wykresy  |  Wywołaj funkcje Kutools...
Popularne funkcje: Znajdź, wyróżnij lub zidentyfikuj duplikaty   |  Usuń puste wiersze   |  Łącz kolumny lub komórki bez utraty danych   |   Okrągły bez wzoru ...
Super wyszukiwanie: Wiele kryteriów VLookup    Wiele wartości VLookup  |   Przeglądanie pionowe na wielu arkuszach   |   Wyszukiwanie rozmyte ....
Zaawansowana lista rozwijana: Szybko twórz listę rozwijaną   |  Zależna lista rozwijana   |  Lista rozwijana wielokrotnego wyboru ....
Menedżer kolumn: Dodaj określoną liczbę kolumn  |  Przesuń kolumny  |  Przełącz stan widoczności ukrytych kolumn  |  Porównaj zakresy i kolumny ...
Polecane funkcje: Fokus siatki   |  Widok projektu   |   Duży pasek formuły    Menedżer skoroszytów i arkuszy   |  Biblioteka zasobów (Automatyczny tekst)   |  Selektor dat   |  Połącz arkusze   |  Szyfruj/odszyfruj komórki    Wysyłaj e-maile według listy   |  Super filtr   |   Specjalny filtr (filtruj pogrubienie/kursywa/przekreślenie...) ...
15 najlepszych zestawów narzędzi12 Tekst Tools (Dodaj tekst, Usuń znaki, ...)   |   50 + Wykres rodzaje (Wykres Gantta, ...)   |   40+ Praktyczne Wzory (Oblicz wiek na podstawie urodzin, ...)   |   19 Wprowadzenie Tools (Wstaw kod QR, Wstaw obraz ze ścieżki, ...)   |   12 Konwersja Tools (Liczby na słowa, Przeliczanie walut, ...)   |   7 Połącz i podziel Tools (Zaawansowane wiersze łączenia, Podział komórki, ...)   |   ... i więcej

Zwiększ swoje umiejętności Excela dzięki Kutools for Excel i doświadcz wydajności jak nigdy dotąd. Kutools dla programu Excel oferuje ponad 300 zaawansowanych funkcji zwiększających produktywność i oszczędzających czas.  Kliknij tutaj, aby uzyskać funkcję, której najbardziej potrzebujesz...

Opis


Karta Office wprowadza interfejs z zakładkami do pakietu Office i znacznie ułatwia pracę

  • Włącz edycję i czytanie na kartach w programach Word, Excel, PowerPoint, Publisher, Access, Visio i Project.
  • Otwieraj i twórz wiele dokumentów w nowych kartach tego samego okna, a nie w nowych oknach.
  • Zwiększa produktywność o 50% i redukuje setki kliknięć myszką każdego dnia!
Comments (7)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Hi, your code is very similar to the one I have done, but I have a question, how can I paste the graphics but I can edit the data in the power point file?
This comment was minimized by the moderator on the site
Hi,

I have tried to run your code, but although it throws me this message it doesn't open any powerpoint, without throwing any error.
The charts shall be in a unique sheet, or there is no problem if they are in a sheet all together?

Thanks.
This comment was minimized by the moderator on the site
Hi Andreas,
You can export a single chart by selecting it and running the first code.
Or export all charts in the workbook with the second code.
Thank you for your comment.
This comment was minimized by the moderator on the site
hello,
How can I have the some things in PDF ?

thanks !
This comment was minimized by the moderator on the site
Hi, Thank you for code.

I tried update your code with a little changes but I don't know how can I do it, I need update/change somes Shape on a specific Slide, but I don't know how can i do it.?
This comment was minimized by the moderator on the site
Hi Antoni,
Sorry can't help you with that yet. Thanks for your comment.
This comment was minimized by the moderator on the site
Thank you, your code worked perfectly for what I needed to do. I will bookmark your page and come back when I need more.
There are no comments posted here yet
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations