Power pointe grafik aktarma

[greatkeops]

merhaba arkadaşlar,
"grafikler" adlı çalışma sayfamda 40 adet grafiğim var. userformda commanbutton1'E tıkladığımda şunları yapabilir miyiz:
yeni bir power point açılsın, grafik 1'i slayt 1'e, grafik 2'yi slayt 2'ye,, bu şekilde 40 tane grafiği aktarabilir miyiz? ardından bu sunuyu masaüstüne "sunugrafiği" olarak kaydetsin ve tekrar userforma geri dönsün." Teşekkürler

 

[mancubus]

aşağıdaki linkte anahtar teslim örnek dosya mevcut.

sayfada aşağıya doğru inip "dowload" link'inden 3 excel versiyonu için hazırlanmış zipli klasörü indirmek mümkün.

ben denedim. gayet güzel oldu.

yapanın eline, emeğine sağlık.

http://www.myengineeringworld.net/2012/11/export-all-excel-charts-to-power-point.html

 

[mancubus]

sunumu kaydeden kodlar eksik.

ana makroyu aşağıdaki ile değiştirmek yeterli. ben kırmızı yaptığım satırları ekledim sadece.

Sub ChartsToPowerPoint()

    'Exports all the chart sheets to a new power point presentation.
    'It also adds a text box with the chart title.
    
    'By Christos Samaras
    'http://www.myengineeringworld.net
    
    Dim ws As Worksheet
    Dim intChNum As Integer
    Dim objCh As Object
[COLOR="red"]    Dim DTop
[/COLOR]    
    'Count the embedded charts.
    For Each ws In ActiveWorkbook.Worksheets
        intChNum = ws.ChartObjects.Count
    Next ws
    
    'Check if there are chart (embedded or not) in the active workbook.
    If intChNum + ActiveWorkbook.Charts.Count < 1 Then
        MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
        Exit Sub
    End If
    
    'Open PowerPoint and create a new presentation.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add
    
    'Loop through all the embedded charts in all worksheets.
    For Each ws In ActiveWorkbook.Worksheets
        For Each objCh In ws.ChartObjects
            Call pptFormat(objCh.Chart)
        Next objCh
    Next ws
    
    'Loop through all the chart sheets.
    For Each objCh In ActiveWorkbook.Charts
        Call pptFormat(objCh)
    Next objCh
    
    'Show the power point.
    pptApp.Visible = True
  
[COLOR="Red"]    With CreateObject("WScript.Shell")
        DTop = .SpecialFolders("Desktop")
    End With
    
    pptPres.SaveAs DTop & "\sunugrafiği.pptx"
[/COLOR]
    'Cleanup the objects.
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    'Infrom the user that the macro finished.
    MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
    
End Sub

 

[greatkeops]

doya yükledim

dosyayı yükledim sayın hocam, inan ki hiçbir şey anlamadım. Userforma girerseniz orada daha detyalı anlattım. Şimdiden teşekkürler

 

[mancubus]

verdiğim linkteki dosyayı indirip kodları dosyanızdaki bir modüle kopyalayın.

hatta dosya indirmeye de gerek yok. direkt o sayfada kodlar var.

istediğiniz bir "button"a "ChartsToPowerPoint" isimli makroyu atayacaksınız. yalnız bu makroya yukarıda yaptığım kırmızı değişiklikleri ekleyeceksiniz.

 

[mancubus]

kendi dosyanızda VBE penceresine iken tools, references adımlarından Microsoft PowerPoint xx.x Object Library'yi işaretlemeyi unutmayın.

Option Explicit

'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).

'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Sub ChartsToPowerPoint()

    'Exports all the chart sheets to a new power point presentation.
    'It also adds a text box with the chart title.
    
    'By Christos Samaras
    'http://www.myengineeringworld.net
    
    Dim ws As Worksheet
    Dim intChNum As Integer
    Dim objCh As Object
    [COLOR="red"]Dim DTop[/COLOR]

    'Count the embedded charts.
    For Each ws In ActiveWorkbook.Worksheets
        intChNum = intChNum + ws.ChartObjects.Count
    Next ws
    
    'Check if there are chart (embedded or not) in the active workbook.
    If intChNum + ActiveWorkbook.Charts.Count < 1 Then
        MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
        Exit Sub
    End If
    
    'Open PowerPoint and create a new presentation.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add
    
    'Loop through all the embedded charts in all worksheets.
    For Each ws In ActiveWorkbook.Worksheets
        For Each objCh In ws.ChartObjects
            Call pptFormat(objCh.Chart)
        Next objCh
    Next ws
    
    'Loop through all the chart sheets.
    For Each objCh In ActiveWorkbook.Charts
        Call pptFormat(objCh)
    Next objCh
    
    'Show the power point.
    pptApp.Visible = True

[COLOR="Red"]    With CreateObject("WScript.Shell")
        DTop = .SpecialFolders("Desktop")
    End With
    
    pptPres.SaveAs DTop & "\sunugrafiği.pptx"[/COLOR]
    [COLOR="Blue"]pptApp.Quit[/COLOR]

    'Cleanup the objects.
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    'Infrom the user that the macro finished.
    MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
    
End Sub

Private Sub pptFormat(xlCh As Chart)
    
    'Formats the charts/pictures and the chart titles/textboxes.
    
    'By Christos Samaras
    'http://www.myengineeringworld.net
    
    Dim chTitle As String
    Dim j As Integer
    
    On Error Resume Next
   'Get the chart title and copy the chart area.
    chTitle = xlCh.ChartTitle.Text
    xlCh.ChartArea.Copy

    'Count the slides and add a new one after the last slide.
    pptSlideCount = pptPres.Slides.Count
    Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
    
    'Paste the chart and create a new textbox.
    pptSlide.Shapes.PasteSpecial ppPasteJPG
    If chTitle <> "" Then
        pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25
    End If
                    
    'Format the picture and the textbox.
    For j = 1 To pptSlide.Shapes.Count
        With pptSlide.Shapes(j)
            'Picture position.
            If .Type = msoPicture Then
                .Top = 87.84976
                .Left = 33.98417
                .Height = 422.7964
                .Width = 646.5262
            End If
            'Text box position and formamt.
            If .Type = msoTextBox Then
                With .TextFrame.TextRange
                    .ParagraphFormat.Alignment = ppAlignCenter
                    .Text = chTitle
                    .Font.Name = "Tahoma (Headings)"
                    .Font.Size = 28
                    .Font.Bold = msoTrue
                End With
            End If
        End With
    Next j

End Sub

 

[greatkeops]

dediğiniz gibi eklemeleri yaptım hocam. Microsoft PowerPoint xx.x Object Library'yi de işaretledim. Yeni sunuyu açıyor, ama grafikleri kopyalamıyor. (grafik1 çalışma sayfasındaki grafiği slayt 1'e, grafik2 çalışma sayfasındaki grafiği slayt 2 'ye aktarmıyor? neden acaba?

 

[mancubus]

boş bir modül ekleyin.

6 nolu mesajdaki kodların tamamını buraya kopyalayın.

VBA'de grafikler user formunu çift tıklayın. formun üzerindeki Aktar düğmesini çift tıklayın.

doğrudan userformun kod modülü açılacak ve kontrole ilişkin Private Sub CommandButton2_Click() - End Sub kod gelecektir. bu iki satırın arasına sadece Call ChartsToPowerPoint satırını kopyalayın.

yani şu olacak:

Private Sub CommandButton2_Click()
    Call ChartsToPowerPoint
End Sub

ben bu şekilde çalıştırdım. = dosyadaki bütün grafikler sunuma 1 grafik / 1 slide olmak üzere kopyalandı.

 

[greatkeops]

şu hatayı veriyor

resim olarak yükledim. (ilginize teşekkürler)

 

[mancubus]

şunu unutmayalım:

reference to Microsoft PowerPoint xx.x Object Library

 

[greatkeops]

şu hataları verdi

yeni sunu açıyor, ama grafikler yok.
excell 2003 kullandığımdan olabilir mi acaba?

 

[mancubus]

öncesinde de aklıma gelmedi değil.

verdiğim linkteki zipli klasör'den 2003 için hazırlanan dosyayı açarak denemenizi öneririm.

 

[greatkeops]

oldu hocam, çok teşekkür ederim. Bununla ilgili son soru: sunuyu açıyor, grafikleri aktarıyor, ama sunuyu kapatmıyor, sunuyu kapatsa mükemmel olacak. Çok sağolasın....

 

[mancubus]

sen sağol.

6 nolu mesajda MAVİ RENKLİ olarak pptApp.Quit satırını ekledim.

 

[greatkeops]

teşekkürler sayın hocam

 

[MuhammedMurat]

Merhabalar yapamadım bir türlü son hali elinizde varsa ek olarak yükleyebilirseniz çok teşekkür ederim.

 

[mancubus]

link verdiğim sitede dosya. oradan indirmek mümkün.