Boş sayfaları atlayarak PDF oluşturma. VBA

[mrttrn]

With Worksheets("KİMLİK")
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=dosya_yolu, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With

ile PDF oluşturuyorum. Ancak Boş sayfaları da kaydediyor.

Excel Sayfa dizilimi aşağıdaki gibi. Genellikle Alt alta 4 sayfa düzeninde yerleşim var. Ama bazı sayfalar BOŞ.

Dolu sayfa	Dolu Sayfa	Dolu Sayfa	Dolu Sayfa
Dolu Sayfa		Dolu Sayfa	Dolu Sayfa
Dolu Sayfa			Dolu Sayfa
Dolu Sayfa

Boş sayfaları atlayarak nasıl PDF oluşturabilirim.

 

[tugkan]

Boş sayfaları atlayarak PDF oluşturmak için, sayfaların dolu olup olmadığını kontrol edebilir ve yalnızca dolu sayfaları kaydedebilirsiniz. Bunu yapmak için sayfadaki içeriği kontrol eden bir VBA kodu yazabiliriz. Örneğin, her sayfanın dolu olup olmadığını hücrelerin boş olup olmamasıyla belirleyebiliriz. Aşağıda, boş sayfaları atlayarak PDF oluşturmanızı sağlayacak bir kod örneği bulabilirsiniz:

Sub PDF_Olustur_Bos_Sayfalari_Atla()
    Dim ws As Worksheet
    Dim doluSayfaListesi As String
    Dim dosya_yolu As String
    Dim sonSatir As Long
    Dim sonSutun As Long
    Dim sonHücre As Range
    Dim doluMu As Boolean
    
    ' PDF dosyasının kaydedileceği yol
    dosya_yolu = "C:\dosya_yolu\kimlik.pdf" ' Dosya yolunu güncelleyin
    
    ' Her sayfayı kontrol et
    For Each ws In ThisWorkbook.Worksheets
        doluMu = False
        
        ' Sayfadaki son dolu hücreyi bul
        On Error Resume Next ' Hata durumunu göz ardı et (boş sayfalar için)
        Set sonHücre = ws.Cells.Find(What:="*", LookIn:=xlFormulas, _
                                    SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        On Error GoTo 0
        
        ' Eğer sayfa boş değilse listeye ekle
        If Not sonHücre Is Nothing Then
            doluMu = True
        End If
        
        ' Dolu sayfa listesine ekle
        If doluMu Then
            doluSayfaListesi = doluSayfaListesi & ws.Name & ","
        End If
    Next ws
    
    ' Sonunda boş sayfaları çıkardıktan sonra PDF oluştur
    If Len(doluSayfaListesi) > 0 Then
        doluSayfaListesi = Left(doluSayfaListesi, Len(doluSayfaListesi) - 1) ' Son virgülü kaldır
        
        ' Dolu sayfalar PDF olarak kaydediliyor
        Worksheets(Split(doluSayfaListesi, ",")).Select
        ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=dosya_yolu, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
    Else
        MsgBox "PDF oluşturmak için dolu sayfa bulunamadı."
    End If
End Sub

Bu kod, her sayfayı tek tek kontrol eder ve yalnızca içeriği dolu olan sayfaları PDF'e ekler. Eğer sayfa boşsa PDF'e dahil edilmez. Dosya yolunu kendinize uygun şekilde güncellemeniz gerektiğini unutmayın.

Boş sayfaları bulmak için Cells.Find yöntemini kullanıyoruz. Eğer herhangi bir hücrede veri varsa, sayfa dolu olarak kabul ediliyor. Eğer sayfa tamamen boşsa, o sayfa atlanıyor.

 

[pitchoute]

Merhabalar, deneyip sonucu paylaşabilir misiniz;

Sub ExportOnlyNonEmptyPagesToPDF()
    Dim ws As Worksheet
    Dim dosya_yolu As String
    Dim PageHeight As Long
    Dim TotalRows As Long
    Dim TotalPages As Long
    Dim i As Long
    Dim StartRow As Long
    Dim EndRow As Long
    Dim rngPage As Range
    Dim NonEmptyRanges As String
    Dim LastRow As Long
    
    Set ws = ThisWorkbook.Worksheets("KİMLİK")
    dosya_yolu = "C:\DosyaYolu\DosyaAdi.pdf"
    
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Bu sayıyı çalışma sayfası ayarlarınıza göre ayarlayın
    PageHeight = 50 ' Ben 50 satır olarak belirledim, ihtiyaçlarınıza göre ayarlayın
    
    TotalPages = Application.Ceiling(LastRow / PageHeight, 1)
    
    NonEmptyRanges = ""
    
    For i = 0 To TotalPages - 1
        StartRow = i * PageHeight + 1
        EndRow = (i + 1) * PageHeight
        If EndRow > LastRow Then EndRow = LastRow
        
        
        Set rngPage = ws.Range("A" & StartRow & ":Z" & EndRow)
        
        If Application.WorksheetFunction.CountA(rngPage) > 0 Then
            If NonEmptyRanges = "" Then
                NonEmptyRanges = rngPage.Address
            Else
                NonEmptyRanges = NonEmptyRanges & "," & rngPage.Address
            End If
        End If
    Next i
    
    If NonEmptyRanges <> "" Then
        ws.PageSetup.PrintArea = NonEmptyRanges
    Else
        MsgBox "Yazdırılacak dolu sayfa bulunamadı.", vbInformation
        Exit Sub
    End If
    
    ws.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=dosya_yolu, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
End Sub