Dönüştürücü

[hamitalper]

merhaba,

İçinde formülle değişkenlik gösteren (bağlı hücrelerin olduğu )bir excel sayfasını Powerpointe dönüştürebilir miyiz. (Excel sayfasında metin kutuları, grafikler ve tabloların olduğu bir excel sayfası). Makro ile mümkün mü yalnız örneğin excelde "Opel" arabasının özelliklerini döküyoruz bunu değiştirdiğimizde "Hyundai" yaptığımızda Powerpoint yeni "hyundai" nin özelliklerini grafik ve tablolaştıracak.

Şimdiden çok teşekkürler.

Basit bir excel tablosu attım.

 

[Trilenium]

Sub ExportToPowerPoint()
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim ws As Worksheet
Dim r As Range

' PowerPoint'i başlat
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True

' Yeni bir sunum oluştur
Set pptPres = pptApp.Presentations.Add

' Excel'deki verileri seçin
Set ws = ThisWorkbook.Sheets("deneme") ' Sayfa adını değiştirmeyi unutmayın
Set r = ws.Range("b2:g51") ' Aralığı değiştirin

' Yeni bir slayt ekle
Set pptSlide = pptPres.Slides.Add(1, 1) ' 1: İçerik slaytı

' Verileri slayta yapıştır
r.Copy
pptSlide.Shapes.PasteSpecial DataType:=2 ' 2: Metin
End Sub

 

[hamitalper]

hocam geri dönüşünüz için teşekkürler , kodu çalıştırınca boş geliyor excelde ki dosyalar aktarılmamış gözüküyor

 

[tugkan]

merhaba,

İçinde formülle değişkenlik gösteren (bağlı hücrelerin olduğu )bir excel sayfasını Powerpointe dönüştürebilir miyiz. (Excel sayfasında metin kutuları, grafikler ve tabloların olduğu bir excel sayfası). Makro ile mümkün mü yalnız örneğin excelde "Opel" arabasının özelliklerini döküyoruz bunu değiştirdiğimizde "Hyundai" yaptığımızda Powerpoint yeni "hyundai" nin özelliklerini grafik ve tablolaştıracak.

Şimdiden çok teşekkürler.

Basit bir excel tablosu attım.

Merhaba,
Aşağıdaki linki incelerseniz excele bağlı powerpoint dosyası oluşturup, excel değiştiğinde powerpoint sayfasının nasıl değiştiğini anlatıyor.

https://support.microsoft.com/tr-tr...leştirme-0690708a-5ce6-41b4-923f-11d57554138d

 

[Trilenium]

buraya gönderdiğiniz sayfada yaptınız di mi denemeyi?

eğer hayır ise

Set ws = ThisWorkbook.Sheets("deneme") ' Sayfa adını değiştirmeyi unutmayın

 

[hamitalper]

buraya gönderdiğiniz sayfada yaptınız di mi denemeyi?

eğer hayır ise

Set ws = ThisWorkbook.Sheets("deneme") ' Sayfa adını değiştirmeyi unutmayın

Hocam merhaba yeni bir slayt ekle kısmına sayfa sayısı ekliyorum tüm sayfaları alması adına ama powerpointe hepsini aynı tek sayfaya alıyor, örnek excelde mesela 3 sayfa var powerpointte de 3 sayfa olcak şekilde dökme imkanımız varmı, yardımlarınız için teşekkürler bu arada

 

[Trilenium]

Hamit Bey ,

Hangi satır aralığındakileri ayrı ayrı aktarmak istiyorsunuz ?

Excel dosyanızı açıyorum 1 - 164 satır aralığı var.

Bu satır aralığında 1- xx xx - yy zz-tt hangi aralığı pp de sayfa sayfa yapılmaasını istiyorsunuz

anlamadım ben sizi.

 

[hamitalper]

merhaba tekrardan hocam mesela son attığım excelde 3 sayfa var, 1-60 sayfa1, 61-121 sayfa2, 123-166 sayfa3 olacak şekilde bire bir aynı excelde saygıdeğer hocam yardımların için çok sağol

 

[Trilenium]

hep böyle mi olacak ?

1-60 61-121 -123 diye mi gidecek kodu ona göre belirliycem

 

[hamitalper]

hep böyle mi olacak ?

1-60 61-121 -123 diye mi gidecek kodu ona göre belirliycem

aynen hocam böyle yaklaşık 50 sayfa var ben sizin koddan sonra işlicem devamını

 

[Trilenium]

Referasnlara bunu ekleyin.




Sub ExportToPowerPoint()
On Error GoTo ErrorHandler
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Dim ws As Worksheet
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim slideIndex As Integer

' PowerPoint'i başlat
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True

' Yeni bir sunum oluştur
Set pptPres = pptApp.Presentations.Add

' Excel'deki verileri seçin
Set ws = ThisWorkbook.Sheets("deneme") ' Sayfa adını değiştirmeyi unutmayın

' Veri aralıklarını seçin
Set r1 = ws.Range("B2:G61") ' 1-60 aralığı
Set r2 = ws.Range("B62:G121") ' 61-121 aralığı
Set r3 = ws.Range("B122:G166") ' 123-166 aralığı

' Her aralık için yeni bir slayt ekle ve verileri slayta yapıştır
For slideIndex = 1 To 3
' Yeni bir slayt ekle
Set pptSlide = pptPres.Slides.Add(slideIndex, 1) ' 1: İçerik slaytı

' Başlık ve altyazı yer tutucularını kaldırmadan önce kontrol et
On Error Resume Next
If pptSlide.Shapes.Placeholders.Count >= 1 Then pptSlide.Shapes.Placeholders(1).Delete ' Başlık
If pptSlide.Shapes.Placeholders.Count >= 2 Then pptSlide.Shapes.Placeholders(2).Delete ' Altyazı
On Error GoTo ErrorHandler

' Veri aralığını slayta yapıştır
Select Case slideIndex
Case 1
r1.Copy
Case 2
r2.Copy
Case 3
r3.Copy
End Select
pptSlide.Shapes.PasteSpecial DataType:=2 ' 2: Metin

' Verileri tam oturt
With pptSlide.Shapes(pptSlide.Shapes.Count)
.LockAspectRatio = msoFalse
.Top = 0
.Left = 0
.Width = pptPres.PageSetup.SlideWidth
.Height = pptPres.PageSetup.SlideHeight
End With
Next slideIndex

Exit Sub

ErrorHandler:
MsgBox "Hata: " & Err.Description, vbCritical

End Sub



Dosyanızda ektedir.

 

[Trilenium]

Set r1 = ws.Range("B2:G61") ' 1-60 aralığı
Set r2 = ws.Range("B62:G121") ' 61-121 aralığı
Set r3 = ws.Range("B122:G166") ' 123-166 aralığı


veri aralıklarını siz daha sonra kendinize göre ayarlarsınız