Soru Makro Çalışmadan Önce Sayfa İsimlerine göre seçim yapmak

[bulentkars]

Arkadaşlar Merhaba;

Aşağıdaki Kod açık olan çalışma kitabındaki tüm sayfaları Powerpoint için sunum hazırlıyor.
Kod içerisinde "AnaSayfa" hariç yapıyor ama zaman zaman istenmeyen sayfalarında yapılmasını istemiyorum.
Bunun İçin Yapmak istediğim;
Makro ilk başladığında tüm sayfaların ismini Listboxta gösterecek.
Sadece seçeceğim sayfalar üzerinden sayfaları PPS yapmak istiyorum. veya hariç sayfaları seçip çalıştırdığımda seçtiğim sayfalar hariç işlem yapacak.
Sizin başka bir önerinizde varsa olabilir. Şimdiden yardımcı olacak arkadaşlara teşekkür ediyorum.

Sub Copy_Excel_To_PPT()

Dim PPT_App As Object
Dim ppt_file As Object
Dim my_slide As Object
Set PPT_App = CreateObject("PowerPoint.Application")


Set ppt_file = PPT_App.Presentations.Add


Dim sh As Worksheet

For Each sh In ActiveWorkbook.Sheets

    If sh.Name <> "AnaSayfa" Then
   
        Set my_slide = ppt_file.Slides.AddSlide(1, ppt_file.SlideMaster.CustomLayouts(6))
       
        my_slide.moveTo (ppt_file.Slides.count)
       
        '''''' Format Slide title
        With my_slide.Shapes.Title
            .TextFrame.TextRange.Text = sh.Name
            .TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
            .Fill.BackColor.RGB = RGB(0, 128, 128)
            .TextEffect.Alignment = msoTextEffectAlignmentCentered
            .TextEffect.FontName = "Arial Rounded MT Bold"
            .Height = 50
        End With
       
        sh.UsedRange.CopyPicture xlScreen, xlPicture
        my_slide.Shapes.Paste
       
        ''''''' Resize and reposition the picture
        With my_slide.Shapes(2)
            .LockAspectRatio = msoCTrue
            .Width = ppt_file.PageSetup.SlideWidth - 30
           
            .Top = 0
            If .Height > ppt_file.PageSetup.SlideHeight Then
                .Height = ppt_file.PageSetup.SlideHeight - 120
            End If
           
            .Left = 0
            If .Width > ppt_file.PageSetup.SlideWidth Then
                .Width = ppt_file.PageSetup.SlideWidth - 30
            End If
            .Left = (ppt_file.PageSetup.SlideWidth - .Width) / 2
            .Top = 100
           
        End With
    End If
Next

MsgBox "Sayfalar Sunu için Hazırlandı..", vbInformation, Application.UserName

End Sub

 

[Ziynettin]

Çalışma dosyanız.

 

[bulentkars]

Sn Ziynettin Bey;
Elinize emeğinize sağlık. Tam istediğim gibi olmuş Teşekkürler