Seçili sekmeleri PDF yapma

[buggsbunny]

Aşağıdaki kod seçili sekmeleri sekme adı ile pdf olarak kaydediyor ancak şöyle bir sıkıntım var. Örneğin 3 tane sekme seçtiysem 3 sekme için 3 tane pdf dosyası oluşturuyor ancak 3 ünde de 3 sekmeyi birleştirerek pdf yapıyor. Yani özetle 3 tane pdf oluşuyor her biride 3 sayfa oluyor tek farklı olan pdf isimleri. içerik aynı.
Benim istediğim seçtiğim her sekmeyi ayrı pdf olarak keydetsin tek başına. kodda nasıl bir değişiklik yapmam lazım

Sub SeciliSekmeleriPdfYap()
Dim Zaman As Double
Zaman = Now
On Error GoTo hata

ChDir Environ("UserProfile") & "\Desktop\"

Dim Ds

Set Ds = CreateObject("Scripting.FileSystemObject")

Ds.CreateFolder Environ("UserProfile") & "\Desktop\PDF"

Bas:

yol = Environ("UserProfile") & "\Desktop\PDF\"
For Each syf In ActiveWindow.SelectedSheets
    syf.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=yol & syf.Name & ".pdf", OpenAfterPublish:=False
Next

MsgBox "İşlem Tamamlandı." & vbLf & vbLf & _
       "İşlem Süresi ; " & Format(Now - Zaman, "hh:mm:ss")
     
      Exit Sub

hata:

bilgi = MsgBox("Masaüstünüzde PDF klasörü mevcut. Dosyalar klasör içerisinde oluşturulacak. Aynı dosya varsa üzerine yazılsın mı?", vbYesNo)

If bilgi = vbYes Then

GoTo Bas

End If

End Sub

 

[alicimri]

ActiveSheet yerine syf yazın yeter.

 

[buggsbunny]

ActiveSheet yerine syf yazın yeter.

Zaten kod öyleydi ben biraz kurcaladım, kurcalalnmış haliyle koymuşum. Şimdi yukarıda yazdığım gibi düzettim deniyorum. Kaç sekme seçersem seçeyim o kadar pdf yapıyor ama hepsini birleştirerek yapıyor. Değişen birşey yok.Her birini sekme adıyla kaydediyor ama seçtiğim tüm sekmeleri birleştiriyor

 

[alicimri]

2013 ofisde deniyorum, dediğim düzeltmeyi yapınca, sayfaları ayrı ayrı ve birleştirmeden, pdf ye dönüştürüyor.

 

[buggsbunny]

2013 ofisde deniyorum, dediğim düzeltmeyi yapınca, sayfaları ayrı ayrı ve birleştirmeden, pdf ye dönüştürüyor.

bendeki 2019

 

[akcygt11]

Dener misiniz

Sub SeciliSekmeleriPdfYap()
    Dim Zaman As Double
    Zaman = Now

    On Error GoTo hata

    ChDir Environ("UserProfile") & "\Desktop\"
    Dim Ds
    Set Ds = CreateObject("Scripting.FileSystemObject")
    Ds.CreateFolder Environ("UserProfile") & "\Desktop\PDF"

Bas:
    Yol = Environ("UserProfile") & "\Desktop\PDF\"

    Dim syf As Worksheet
    For Each syf In ActiveWindow.SelectedSheets
        
        syf.Select
      
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Yol & syf.Name & ".pdf", OpenAfterPublish:=False
    Next

    MsgBox "İşlem Tamamlandı." & vbLf & vbLf & _
        "İşlem Süresi ; " & Format(Now - Zaman, "hh:mm:ss")

    Exit Sub

hata:
    bilgi = MsgBox("Masaüstünüzde PDF klasörü mevcut. Dosyalar klasör içerisinde oluşturulacak. Aynı dosya varsa üzerine yazılsın mı?", vbYesNo)
    If bilgi = vbYes Then
        GoTo Bas
    End If
End Sub

 

[buggsbunny]

Sub SeciliSekmeleriPdfYap() Dim Zaman As Double Zaman = Now On Error GoTo hata ChDir Environ("UserProfile") & "\Desktop\" Dim Ds Set Ds = CreateObject("Scripting.FileSystemObject") Ds.CreateFolder Environ("UserProfile") & "\Desktop\PDF" Bas: Yol = Environ("UserProfile") & "\Desktop\PDF\" Dim syf As Worksheet For Each syf In ActiveWindow.SelectedSheets syf.Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=Yol & syf.Name & ".pdf", OpenAfterPublish:=False Next MsgBox "İşlem Tamamlandı." & vbLf & vbLf & _ "İşlem Süresi ; " & Format(Now - Zaman, "hh:mm:ss") Exit Sub hata: bilgi = MsgBox("Masaüstünüzde PDF klasörü mevcut. Dosyalar klasör içerisinde oluşturulacak. Aynı dosya varsa üzerine yazılsın mı?", vbYesNo) If bilgi = vbYes Then GoTo Bas End If End Sub

çok teşekkürler oldu bu