Birden Fazla PDF Kaydetme Makrosu

[akmlyx]

Değerli Arkadaşlar Merhaba,
Örneği ekteki Çalışma isimli belgede görüleceği üzere, Excel sayfasında ayrı ayrı yazdırma alanı tanımlanmış 10 sayfanın her birini masa üstündeki "İşçi Ücret Bordrosu" klasörüne PDF olarak ayrı ayrı kaydedecek makro yazılabilir mi? Kısaca 10 ayrı PDF dosyası oluşturacak.
Belgelerin isimleri de, isimlerin yazılı bulunduğu hücrelerden almasını istiyorum. Örneğim 1. belge ismini F2 hücresinden alsın, 2. Belge isnin C35 hücresinden alarak devam etsin. Yardımınız için şimdiden Teşekkür Ederim.

 

[ÖmerFaruk]

Çalışan bir PDF yazdırma örneği

Sub PrintPdf()
Dim Fs As Object
Dim ShYaz As Worksheet
Dim Yol, PdfName As String
Dim fdObj As Object
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    KlasorYolu = ThisWorkbook.Path & "\"
    Klasor = "RaporKlasörü-" & DosyaDonemi
    If fdObj.FolderExists(KlasorYolu & Klasor) Then
        GoTo Yazdır1
    Else
        fdObj.CreateFolder (KlasorYolu & Klasor)
    End If
  
Yazdır1:
    Yol = KlasorYolu & "\" & Klasor

    For i = 1 To 9
        Select Case i
        Case 1
            PdfName = "Ek-1.pdf" 'Referans olarak bir hücreyi verebilirsiniz
            Set ShYaz = Worksheets("AidatDökümü") ' istediğiniz sayfa adını belirtebilir ya da bir hücre içeriğinden yazabilirsiniz
        Case 2
            PdfName = "Ek-2.pdf"
            Set ShYaz = Worksheets("Gelir")
        Case 3
            PdfName = "Ek-3.pdf"
            Set ShYaz = Worksheets("Gider")
        Case 4
            PdfName = "Ek-4.pdf"
            Set ShYaz = Worksheets("Özet")
        Case 5
            PdfName = "Ek-5A.pdf"
            Set ShYaz = Worksheets("KasaÖzet")
        Case 6
            PdfName = "Ek-5B.pdf"
            Set ShYaz = Worksheets("Kasa")
        Case 7
            PdfName = "Ek-6.pdf"
            Set ShYaz = Worksheets("Aidatlar")
        Case 8
            PdfName = "Ek-7.pdf"
            Set ShYaz = Worksheets("CariListe")
        Case 9
            PdfName = "RaporKapak.pdf"
            Set ShYaz = Worksheets("Kapak")
        End Select
        With ShYaz
            .ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=Yol & "/" & PdfName, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        End With
    Next i
End Sub

 

[akmlyx]

Çalışan bir PDF yazdırma örneği

Sub PrintPdf()
Dim Fs As Object
Dim ShYaz As Worksheet
Dim Yol, PdfName As String
Dim fdObj As Object
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    KlasorYolu = ThisWorkbook.Path & "\"
    Klasor = "RaporKlasörü-" & DosyaDonemi
    If fdObj.FolderExists(KlasorYolu & Klasor) Then
        GoTo Yazdır1
    Else
        fdObj.CreateFolder (KlasorYolu & Klasor)
    End If
 
Yazdır1:
    Yol = KlasorYolu & "\" & Klasor

    For i = 1 To 9
        Select Case i
        Case 1
            PdfName = "Ek-1.pdf" 'Referans olarak bir hücreyi verebilirsiniz
            Set ShYaz = Worksheets("AidatDökümü") ' istediğiniz sayfa adını belirtebilir ya da bir hücre içeriğinden yazabilirsiniz
        Case 2
            PdfName = "Ek-2.pdf"
            Set ShYaz = Worksheets("Gelir")
        Case 3
            PdfName = "Ek-3.pdf"
            Set ShYaz = Worksheets("Gider")
        Case 4
            PdfName = "Ek-4.pdf"
            Set ShYaz = Worksheets("Özet")
        Case 5
            PdfName = "Ek-5A.pdf"
            Set ShYaz = Worksheets("KasaÖzet")
        Case 6
            PdfName = "Ek-5B.pdf"
            Set ShYaz = Worksheets("Kasa")
        Case 7
            PdfName = "Ek-6.pdf"
            Set ShYaz = Worksheets("Aidatlar")
        Case 8
            PdfName = "Ek-7.pdf"
            Set ShYaz = Worksheets("CariListe")
        Case 9
            PdfName = "RaporKapak.pdf"
            Set ShYaz = Worksheets("Kapak")
        End Select
        With ShYaz
            .ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=Yol & "/" & PdfName, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        End With
    Next i
End Sub

Hocam excel'e uyarlayamadım. Bir zahmet excel'e uyarlayıp dosya olarak yükleyebilir misiniz? Teşekkür ederim.

 

[ÖmerFaruk]

Yani biraz gayret gösterin istiyorum.
Forumdaki bir başka pdf kaydetme örneği aşağıda
https://www.excel.web.tr/threads/pdf-yapma.188276/

Tek yapmanız gereken 10 sayfanın ismini manuel olarak tek tek vermeniz gerekiyor
Ya aynı işlemi 10 kez alt alta yazın ya da bir döngü içinde 10 adet kaydetme işlemi için 10 adet sayfanızın ismini belirtin.

 

[ÖmerFaruk]

Sorunuzu tam okumamışım. Kusura bakmayın.
Bu kodları Module içine ya da sayfanın kod sayfasına yazıp çalıştırabilirsiniz.
Sayfa isimlerinin boş gelmemesine dikkat edin.

Sub YazdırmaAlanları_PDF_Yaz()
    Dim i As Integer
    Dim Yol As String
    Dim PdfName As String
    For i = 1 To 10
        Select Case i
            Case 1
            PdfName = [F2] & ".pdf"
            Case 2
            PdfName = [C35] & ".pdf" ' Bu satırları diğer 8 sayfa içinde CASE sorgusunun altına düzenleyin.
            Case 3
            Case 4
            Case 5
            Case 6
            Case 7
            Case 8
            Case 9
            Case 10
        End Select
        If Len(PdfName)<6 Then MsgBox "Sayfa İsmi Eksik": Exit Sub
        Yol = Environ("USERPROFILE") & "\Desktop"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Yol & "\" & PdfName, From:=i, To:=i, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False
    Next i
    i = Empty: Yol = vbNullString: PdfName = vbNullString
End Sub

 

[akmlyx]

Sorunuzu tam okumamışım. Kusura bakmayın.
Bu kodları Module içine ya da sayfanın kod sayfasına yazıp çalıştırabilirsiniz.
Sayfa isimlerinin boş gelmemesine dikkat edin.

Sub YazdırmaAlanları_PDF_Yaz()
    Dim i As Integer
    Dim Yol As String
    Dim PdfName As String
    For i = 1 To 10
        Select Case i
            Case 1
            PdfName = [F2] & ".pdf"
            Case 2
            PdfName = [C35] & ".pdf" ' Bu satırları diğer 8 sayfa içinde CASE sorgusunun altına düzenleyin.
            Case 3
            Case 4
            Case 5
            Case 6
            Case 7
            Case 8
            Case 9
            Case 10
        End Select
        If Len(PdfName)<6 Then MsgBox "Sayfa İsmi Eksik": Exit Sub
        Yol = Environ("USERPROFILE") & "\Desktop"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Yol & "\" & PdfName, From:=i, To:=i, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False
    Next i
    i = Empty: Yol = vbNullString: PdfName = vbNullString
End Sub

Üstadım, NextLevel Hocam, yazdığınız makronun kalan kısımlarını tamamladım gayet güzel çalıştı. Emeğinize sağlık TEŞEKKÜR EDERİM.