Boş sayfa sorunu

muratgunay48 · Dün 14:03 da

Arkadaşlar, sayın hocalarım, şöyle bir kod yazdım ama 5000'e kadar boş sayfaları da alıyor. Hatam nerede acaba?
Şimdiden teşekkür ederim.
Saygılarımla.

Kod:

Sub donusturme()
'Sayfa seç
Worksheets("Tümü").Activate
'Saütunları sil
Columns("A:A").Delete
Columns("H:M").Delete
'Satırları sil
Rows("1:1").Delete
'Satır yüksekliği
'Cells.RowHeight = 15 'Tüm sayfa
Rows("1:1").RowHeight = 30
Rows("2:5000").RowHeight = 15
'Satırları dikey ortala
Cells.VerticalAlignment = xlCenter
'Satırı yatay ortala
Range("A1:G1").HorizontalAlignment = xlCenter
'Satır punto büyüklüğü
Rows("1:1").Font.Size = 14
'Sütun genişlikleri
Columns("A:A").ColumnWidth = 4
Columns("B:B").ColumnWidth = 14
Columns("C:C").ColumnWidth = 13
Columns("D:D").ColumnWidth = 8
Columns("E:E").ColumnWidth = 20
Columns("F:F").ColumnWidth = 50
Columns("G:G").ColumnWidth = 20
'Sütun yatay ortala
Columns("A:A").HorizontalAlignment = xlCenter
Columns("B:B").HorizontalAlignment = xlCenter
Columns("C:C").HorizontalAlignment = xlCenter
Columns("D:D").HorizontalAlignment = xlCenter
'Sütun hücre taşmasın (doldur)
Range("G2:G5000").Select
With Selection
        .HorizontalAlignment = xlFill
        .VerticalAlignment = xlCenter
    End With
'Sayfa yapısı
Dim ws As Worksheet
    Set ws = ActiveSheet
        With ws.PageSetup
        .LeftMargin = Application.CentimetersToPoints(1.5) ' Sol boşluk
        .RightMargin = Application.CentimetersToPoints(1.5) ' Sağ boşluk
        .TopMargin = Application.CentimetersToPoints(2) ' Üst boşluk
        .BottomMargin = Application.CentimetersToPoints(2) ' Alt boşluk
        .HeaderMargin = Application.CentimetersToPoints(0) ' Üstbilgi
        .FooterMargin = Application.CentimetersToPoints(0) ' Altbilgi
        .CenterHorizontally = True ' Yatay ortala
        .CenterVertically = True ' Dikey ortala
        '.Orientation = xlLandscape ' Yatay sayfa (xlPortrait = Dikey)
        .PaperSize = xlPaperA4 ' A4 kağıt boyutu
    End With
'Boş sayfaları sil
Application.DisplayAlerts = False 'Uyarı mesajlarını kapat
For Each ws In Worksheets
    'Sayfada veri olup olmadığını kontrol et
        If Application.WorksheetFunction.CountA(ws.UsedRange) = 0 And ws.UsedRange.Cells.Count = 1 Then
           ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True 'Uyarı mesajlarını aç
End Sub

muratgunay48 · Dün 18:47 da

Sayın hocalarım, lütfen ilgilenin. Bu akşam raporları dönüştürmem lazım. Çok rica ediyorum. İnternette çok aradım başarılı olamadım.

netzone · Dün 19:36 da

Merhaba Murat bey,

Söz konusu sorunuza bakıp sebep sonuç arıyorum ancak sonuca ilişkin bir belirteciniz yok!
5000. satıra kadar biçimlendirmiş ve seçtirmişsiniz..
"5000'e kadar boş sayfaları da alıyor" söyleminiz havada kalıyor.
Sorunuzu sorarken yazdığınız kodları ne yapmak için yazdığınızı ve sonuç olarak aldığınız hatayı belirtip aslında şöyle yapmaya çalışmıştım derseniz daha anlaşılır olacağı kanaatindeyim.

İyi çalışmalar.

muratgunay48 · Dün 19:45 da

netzone' Alıntı:
Merhaba Murat bey,

Söz konusu sorunuza bakıp sebep sonuç arıyorum ancak sonuca ilişkin bir belirteciniz yok!
5000. satıra kadar biçimlendirmiş ve seçtirmişsiniz..
"5000'e kadar boş sayfaları da alıyor" söyleminiz havada kalıyor.
Sorunuzu sorarken yazdığınız kodları ne yapmak için yazdığınızı ve sonuç olarak aldığınız hatayı belirtip aslında şöyle yapmaya çalışmıştım derseniz daha anlaşılır olacağı kanaatindeyim.

İyi çalışmalar.

Hocam siteden rapor alıyoruz. Onu bu şekilde dönüştürüyoruz. İlk raporu aldığımız. Bazen 3000-4000 satır olabiliyor. O yüzden.

netzone · Dün 21:36 da

Murat Bey,

Cevap vermişsiniz teşekkürler de hala 5000 satır yerine ne olmasını bekliyorsunuz bunu izah etmemişsiniz!

Bende görüyorum kodlarınızın; boş olan sayfaları silip Tümü adlı sayfada sabit bir görünüm kazandırmak için yazıldığını, sorun şu ki 5000 satır yerine 2000 satırlık veri varsa ne yapmasını istiyorsunuz?

muratgunay48 · Dün 23:13 da

netzone' Alıntı:
Murat Bey,

Cevap vermişsiniz teşekkürler de hala 5000 satır yerine ne olmasını bekliyorsunuz bunu izah etmemişsiniz!

Bende görüyorum kodlarınızın; boş olan sayfaları silip Tümü adlı sayfada sabit bir görünüm kazandırmak için yazıldığını, sorun şu ki 5000 satır yerine 2000 satırlık veri varsa ne yapmasını istiyorsunuz?

Hocam sonu şöyle bitiyor.

Kod:

    ChDir "C:\Users\muratgunay48\Desktop"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "C:\Users\muratgunay48\Desktop\AAA.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False       
End Sub

Yani PDF olarak kaydedecek. 5000'in amacı, ben o gün kaç satır rapor çıkacak bilemem ki. Mesela 1150 çıktı. Satır-sütun yapılandıracak ve PDF olarak kaydedecek.

netzone · Bugün 00:01

muratgunay48' Alıntı:
Hocam sonu şöyle bitiyor.

Kod:

ChDir "C:\Users\muratgunay48\Desktop" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\Users\muratgunay48\Desktop\AAA.pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False End Sub

Yani PDF olarak kaydedecek. 5000'in amacı, ben o gün kaç satır rapor çıkacak bilemem ki. Mesela 1150 çıktı. Satır-sütun yapılandıracak ve PDF olarak kaydedecek.

Yukarıda paylaşmış olduğunuz kodun içerisinde böyle bir alan yer almamakla birlikte sorunuzun cevabına gelecek olursak;
Biçimlendirme yapmış olduğunuz alanlar her ne kadar içi boş olsa da çıktınızda yer alır, bunun için biçimlendirmeyi son dolu hücreyi tespit ettirip o alana biçimlendirme uygulamanız gerekmektedir.

İyi çalışmalar.

muratgunay48 · Bugün 00:26

Sayın hocalarım
'Sütun hücre taşmasın (doldur)
Range("G2:G5000").Select
With Selection
.HorizontalAlignment = xlFill
.VerticalAlignment = xlCenter
End With

Bundan oluyor sanırım. Ama hücreden taşmaması lazım. Nasıl yapacağım.

netzone · Bugün 01:00

Dosyanızın yedeğini alıp aşağıdaki kodları deneyiniz. *Kodlar yapay zeka tarafından yazıldı.

İyi çalışmalar.

C++:

Sub donusturme_Guncel()
    Dim ws As Worksheet
    Dim sonSatir As Long
   
    'Sayfa seç
    Set ws = Worksheets("Tümü")
    ws.Activate
   
    '--- 1. SON SATIRI BUL ---
    'B sütununa bakarak en son dolu satırı bulur (B sütunu genelde doludur diye seçtik)
    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
   
    'Eğer veri yoksa işlemi durdur (Başlık hariç veri yoksa)
    If sonSatir < 2 Then sonSatir = 2

    'Sütunları sil
    ws.Columns("A:A").Delete
    ws.Columns("H:M").Delete
   
    'Satırları sil
    ws.Rows("1:1").Delete
   
    'Yeniden son satırı hesapla (Silme işleminden sonra değişmiş olabilir)
    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    '--- 2. DİNAMİK BİÇİMLENDİRME ---
    ws.Rows("1:1").RowHeight = 30
    'Sadece dolu olan satırların yüksekliğini ayarla
    ws.Rows("2:" & sonSatir).RowHeight = 15
   
    ws.Cells.VerticalAlignment = xlCenter
    ws.Range("A1:G1").HorizontalAlignment = xlCenter
    ws.Rows("1:1").Font.Size = 14
   
    'Sütun genişlikleri
    ws.Columns("A:A").ColumnWidth = 4
    ws.Columns("B:B").ColumnWidth = 14
    ws.Columns("C:C").ColumnWidth = 13
    ws.Columns("D:D").ColumnWidth = 8
    ws.Columns("E:E").ColumnWidth = 20
    ws.Columns("F:F").ColumnWidth = 50
    ws.Columns("G:G").ColumnWidth = 20
   
    'Hizalamalar
    ws.Range("A:D").HorizontalAlignment = xlCenter
   
    'Hücre taşmasını önle (Sadece dolu olan G hücreleri için)
    With ws.Range("G2:G" & sonSatir)
        .HorizontalAlignment = xlFill
        .VerticalAlignment = xlCenter
    End With

    '--- 3. SAYFA YAPISI ---
    With ws.PageSetup
        .PrintArea = "A1:G" & sonSatir 'Yazdırılacak alanı SADECE dolu satırlarla sınırla
        .LeftMargin = Application.CentimetersToPoints(1.5)
        .RightMargin = Application.CentimetersToPoints(1.5)
        .TopMargin = Application.CentimetersToPoints(2)
        .BottomMargin = Application.CentimetersToPoints(2)
        .CenterHorizontally = True
        .PaperSize = xlPaperA4
    End With

    '--- 4. BOŞ SAYFALARI SİL ---
    Application.DisplayAlerts = False
    For Each ws In Worksheets
        If Application.WorksheetFunction.CountA(ws.UsedRange) = 0 Then
           ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True

    MsgBox "İşlem başarıyla tamamlandı. Yazdırma alanı " & sonSatir & ". satıra kadar sınırlandı.", vbInformation
End Sub