• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Adet kadar sayfa aç, numaralandır ve pdf olarak kaydet makrosu hk.

  • Konbuyu başlatan Konbuyu başlatan chngrcn
  • Başlangıç tarihi Başlangıç tarihi
silindi ....................
 
askm kodun sadece 4 sayfa kaydediyor.. çalışmıyor..
 
halit hocam 13 nolu mesajda eklediğim ek'e uygulama şansımız varmıdır ?

orda eklediğim ekte, 160 bin küsür sayfa var.. baskı önizlemede görebilirsiniz.. ve bütün sayfalar numaralı bi şekilde.. t5 hücresindeki adet kadar pdf olarak kaydedecek..
 
Son düzenleme:
Ekteki dosya A8 ile I1500 arasını 30 sayfa olarak pdf kaydediyor. 1500/50 =30 Sayfa kaydediyor. 100 yazıp PDF olarak keydet tuşuna basın, deneyin.
 

Ekli dosyalar

Kontrol ediniz.

https://upterabit.com/Ukj/NUMARATİK.xlsm


Not: 160 bin sayfa var ise bu kodları kullanmayınız :)
İlk mesajımdaki çözüm bence sizin için oldukça uygun duruyor. Deneyiniz.

Kod: 
Dim basla, bitir As Long

Sub menu()
  Sheets("NUMARA").Select
  basla = [F4]
  bitir = [F5]
  Call bicim_ayarla
  Call sayfa_olustur
  Call yazici_ayarla
  Call pdf_kaydet
  Cells(1, 1).Select
End Sub

Sub pdf_kaydet()
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
  ThisWorkbook.Path & "\" & "SonucDosyasi", Quality:=xlQualityStandard, _
  IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

Sub bicim_ayarla()
    Sheets("Sablon").Select
    Rows("1:1").RowHeight = 15
    Rows("2:2").RowHeight = 26.25
    Rows("3:1000000").Select
    Selection.RowHeight = 15
    Columns("A:L").Select
    Selection.ColumnWidth = 8.43
    Range("H5").Select
    Columns("K:K").Select
    Range("K2").Activate
    Selection.ClearContents
    Range("K2").Select
    
End Sub

Sub sayfa_olustur()
  Sheets("Sablon").Select
  say = 2
  For i = basla To bitir
    Cells(say, "K").Value = i
    
    Cells(say, "K").Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Font.Bold = True
    
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Rows(say & ":" & say).RowHeight = 26.25
    say = say + 57
  Next i
End Sub

Sub yazici_ayarla()
    Sheets("Sablon").Select
    Application.CutCopyMode = False
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub
 
sn askm,

24 nolu mesajdaki çalışmanız işe yaradı ama sayfa sayısı arttıkça kasma yapıyor.. aşırı derecede hemde..

Kod: 
Sub farklı_kaydetme_pdf()
Application.ScreenUpdating = False
say = ActiveSheet.HPageBreaks.Count + 1
bitis = Worksheets("NUMARA").Range("T5").Value * 50
[COLOR="Red"]ActiveSheet.PageSetup.PrintArea = "$A$8:$I$" & bitis ' & Range("b65536").End(3).Row[/COLOR]

dosya_adı = Cells(3, "T").Value
If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")
If a = vbYes Then
For a = 1 To say
  [k6] = a & " / " & say
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next
MsgBox "işlem tamam!"
End If
If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
End If

Application.ScreenUpdating = True

End Sub

kırmızı renkli olan kısımda her defasında "yazdırma alanı" belirleyip sayfa sayısını belirliyorsunuz. bu kısım oldukça kasıyor..

örneğin;
1000 sayfa "yazdırma alanı" olan bi çalışmada;
sadece 1 ile 40 arasındaki tüm sayfaları pdf olarak kaydetmek istiyorum.. bu makro ile mümkün değil mi arkadaşlar ?

işin içinden çıkamadık gitti.. yardımlarınızı rica ediyorum..
 
Bitiş değerini 10000 olarak girdim zaman sayacı ekledim. 14,93 sn sürdü. Dediğiniz kısım döngüye girmiyor. Bir kereliğine yazdırma alanı belirliyor. Pdf olarak kaydetme işlemi biraz uzun sürüyor. Yani 14,93 sn nin 3 sn işlem 11,93 sn kısmı yayınlanması. Yani pdf kaydetme işlemi.
 
sevgili askm,
yardımların için çok teşekkür ederim. Yanlış anlaşılma ve sert üslup ile anlaşıldıysam da çok özür dilerim. Saygılarımı sunarım.
 
silindi ......................
 
Halit hocam, dediğiniz gibi haklısınız.
sütun boyutlarını 8,43 ( 64 piksel ) piksel yaptım.
aşağıdaki kodda kırmızı işaretlenen kısımda, yazdırma alanını a15 ile J sütunun bitiş satırına kadar yazdırma alanı belirliyor. sütun boyutlarının yukarıdaki ölçüler olması neticesinde tam olumlu sonuç alınıyor. oluşturulan pdf işime yaradı.. dosyanın son hali ektedir. İlginiz için teşekkür ederim halit hocam.


Kod: 
Sub farklı_kaydetme_pdf()
say = ActiveSheet.HPageBreaks.Count + 1
bitis = Worksheets("NUMARA").Range("C2").Value * 50
[COLOR="Red"]ActiveSheet.PageSetup.PrintArea = "$A$15:$J$" & bitis[/COLOR] ' & Range("A65536").End(3).Row

dosya_adı = Cells(1, "C").Value
If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")
If a = vbYes Then
For a = 1 To say
  [C3] = a & " / " & say
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next
MsgBox "işlem tamam!"
End If
If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
End If
End Sub
 

Ekli dosyalar

silindi ........................
 
son düzeltilmiş hali 31 nolu mesajdaki dosyadır halit hocam. deneme yanılma yöntemleri ile en son hali...
 
silindi ......................
 
silindi ........................
 
silindi ............................
 
inceledim halit hocam, ancak istediğimi sağlayamadım..

31 nolu mesajdaki dosyada hali ile işimi çözdüm. takır takır çalışıyor ve pdf'i oluşturuyor..

sizin;
34 nolu mesajınızdaki dosyayı incelediğimde ise,
c2 veya k3 hücresine bitiş sayfasını "2" yapıyorum. hazırla butonuna basıyorum, 100 sayfa hazırlıyor.. pdf kaydet butonuna bastığımda nereye kaydettiğini bulamıyorum..
 
silindi ....................
 
silindi ...................
 
Evet halit hocam dediklerinizin hiç birini yapmıyor.. sizin yaptığınız en son dosyayı düzenleyip ekleme şansınız varmı ?
-------------------------------------------------------------------------------------------------------
halit hocam 38 nolu mesajdaki görsel videonuzu ve dosyanızı inceledim, gerekli düzenlemeleri yapmışsınız.. ellerinize sağlık.. önemli bir konu başlığı ve güzel bir çalışma oldu..
----------------------------------------------------------------------
halit hocam ek olarak bişey sormak istiyorum

başlangıç sayfasını 1 yapınca pdf olarak kaydet dediğimizde ilk sayfanın numarasını atamıyor.. ona bir bakabilir misiniz ?
birde başlangıç 1 - bitiş 75 yaptığımda pdf kaydet 2 butonuna tıklandığında 100 sayfa olarak pdf oluşturuyor..
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst