• DİKKAT

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

kod içerisinde yazdırma komutlarına pdf ekletmek

E

euphrates55

Katılım
25 Ocak 2006
Mesajlar
763
Excel Vers. ve Dili
2019 tr
Kod: 
Sub raporyaz()

    xy = InputBox("KAÇ KOPYA OLACAK")
        If xy = "" Then
    MsgBox "başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If
 sh = InputBox("son satır sayısı (harfsiz)")
    If sh = "" Then
MsgBox "son satır numarasını yazmadınız.", vbInformation, "        Uyarı"
Exit Sub
End If

    Sheets("İCMAL").Select
    ActiveSheet.PageSetup.PrintArea = "$B$2:$BD$34"
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
    ActiveSheet.PrintOut Copies:=xy
    Sheets("GT").Select
    'icmal sayfası seç, b2:bd34 arasını yazdırma alanı seç ve yazdır.

    Sheets("GT").Select
    Cells.Select


    Selection.EntireColumn.Hidden = False
    Selection.EntireRow.Hidden = False
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    'gt sekmesine geç, filtre temizle ve satır sütunlarda gizlenenleri aç
    

    
    
    x = Range("$A$2").Row
    y = Range("$FI$" & sh).Column
    
    w = Range("$G$2").Row
    q = Range("$CI$" & sh).Column

    Sheets("gt").Select
Range("A2").AutoFilter 1, "T"
Range("a2").AutoFilter 5, "<>İhale Edilmesi Planlanıyor"

    'gt sekmesinde boş olanları gösterme şeklinde filtrele (burada T yi göster oluyor)

    Range("A:F,M:Q,U:U,W:W,Y:Z,AB:AB,AE:AF,AH:AI,AU:CH,CJ:KL").Select
    Selection.EntireColumn.Hidden = True
    'SÜTUNLARI SEÇ VE GİZLE
    

    
    ActiveSheet.PageSetup.PrintArea = "$G$2:$CI$" & sh
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
    ActiveSheet.PrintOut Copies:=xy
 End With
 
 

    Cells.Select
    Selection.EntireColumn.Hidden = False


    Range("A:F,I:ax,CJ:KP").Select
    Selection.EntireColumn.Hidden = True
    'SÜTUNLARI SEÇ VE GİZLE
    
  End With
    ActiveSheet.PageSetup.PrintArea = "$G$2:$CI$" & sh
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
    ActiveSheet.PrintOut Copies:=xy
    
    
 End With
    Cells.Select
    Selection.EntireColumn.Hidden = False
    Selection.EntireRow.Hidden = False
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    Range("G3").Select
    MsgBox "Rapor Yazıldı. Yazıcıya Gidebilirsin...", vbInformation
End Sub

günaydınlar.... bakınca anlayacağınız gibi, kod içerisinde belli başlı, gizleme saklama filtreleme yaparak 3 adet farklı tablo oluşturup yazdırma işlemi yaptırıyorum. yazıcıya gönderiyor. kodda sıkıntı yok. istediğim olay ise (olabiliyorsa) bu 3 farklı tablo olarak yapılan yazdırma işlemini yaptığı gibi aynı zamanda 1 pdf içinde toplatarak, bu excel dosyasının bulunduğu yere ekletmek istiyorum.
 
pdf leri hallettim. istediğim klasör içinde 3 adet pdf dosyası oluşuyor. sıra geldi birleştirmeye. işte buna çok baktım sağdan soldan ama istediğimi bulamadım. tek sorunum ayrı bir modülde pdf birleştirme işi. buradan yukarıdaki koda bu modülü çağırttırarak da yapabilirim.

"Z:\2019\RAPORLAR\harcama\gösterim\OTORAPOR\" klasöründe a,b,c adında 3 adet pdf dosyam oluyor. bu 3 pdf dosyasının birleştirilerek rapor_bugünün tarihi_saati şeklinde bir birleşik pdf yaratması.

pdf işini aşağıdaki kodu ekleyerek hallettim.
Kod: 
    With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="Z:\2019\RAPORLAR\harcama\gösterim\OTORAPOR\" & "İhaleler" & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

pdf birleştiremiyorsak eğer, bu koda nasıl bir ekleme yaparsam bu dosyaları excel olarak kaydedebilirim ve sonra a bunları pdf olarak birleştirebilirim sorusu da sorulabilir.
 
Son düzenleme:
Bence bu birleştirme işlemini ilk PDF yazdırma anında yapmanız daha uygun ve pratik olacaktır.
 
Sadece MS Office Excel programını kullanarak, bilgisayarınızdaki mevcut PDF dosyalarını birleştiremez, bölemezsiniz.

PDF dosyalarını Excel ile üretiyorsanız, birleştirmek için; ya Korhan Beyin dediği gibi dosyaları oluşturma aşamasında yapacaksınız ya da bu iş için harici programlar kullanacaksınız.

.
 
Haluk' Alıntı:
Sadece MS Office Excel programını kullanarak, bilgisayarınızdaki mevcut PDF dosyalarını birleştiremez, bölemezsiniz.

PDF dosyalarını Excel ile üretiyorsanız, birleştirmek için; ya Korhan Beyin dediği gibi dosyaları oluşturma aşamasında yapacaksınız ya da bu iş için harici programlar kullanacaksınız.

.
Genişletmek için tıkla ...

peki pdf yazdırmak yerine çıktıyı yazıcıya gönderdikten sonra bunu ayrı bir excel çalışma sayfası olarak kaydedebilir miyim. 3 excel olacak ve bunları pdf olarak toplu kaydedeceğim


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
Kod: 
ActiveSheet.Copy
ActiveWorkbook.SaveAs "Z:\2019\RAPORLAR\harcama\gösterim\OTORAPOR\" & "İcmal.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.Close

bu şekilde halledebileceğimi düşünüyorum, denedim fakat bu seferde linklerden dolayı tüm tablo başvuru hatası veriyor. özel yapıştır yaptığımda da gizli hücreler olduğundan sanırım yapıştırmıyor. nasıl bir kod eklersem linkleri yani bağlantıları kaldırarak yeni sayfa olarak çoğaltabilirim.
 
Örnek dosyanızı paylaşıp ne yapmak istediğinizi açıklarsanız size daha iyi yardımcı olabiliriz.
 
tekrar merhaba. tüm işlemlerimi hallettim. son bir sorum kaldı. aşağıda vereceğim kod içerisinde klasör yaratma kısmında eğer oluşturulacak klasör mevcut durumda var ise hata alıyorum. buraya ekleyeceğimiz bir komut ile bu durumla karşılaştığında "aynı isimle klasör var, klasör oluşturulamadı..." şeklinde mesaj çıkmasını ve işlemi sonlandırmasını istiyorum. eğer ki klasör oluşturmasında sakınca yoksa diğer işlemler devam etsin.
Kod: 
Sub raporyaz()
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
DateString1 = Format(Now, "dd-mm-yyyy")
ds.CreateFolder "Z:\A\B\C\D\" & DateString1

    xy = InputBox("KAÇ KOPYA OLACAK")
        If xy = "" Then
    MsgBox "başlangıç hücresini yazmadınız.", vbInformation, "        Uyarı"
    Exit Sub
    End If
 sh = InputBox("son satır sayısı (harfsiz)")
    If sh = "" Then
MsgBox "son satır numarasını yazmadınız.", vbInformation, "        Uyarı"
Exit Sub




End If
    Sheets("İc").Select
    ActiveSheet.PageSetup.PrintArea = "$B$2:$BD$34"
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
    Application.PrintCommunication = False
    ActiveSheet.PrintOut Copies:=xy
 
With ActiveSheet
DateString = Format(Now, "dd-mm-yyyy hh-mm-ss")

.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="Z:\A\B\C\D\" & DateString1 & "\" & "İc_" & DateString & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

End With
    Sheets("GT").Select
    'icmal sayfası seç, b2:bd34 arasını yazdırma alanı seç ve yazdır.

    Sheets("GT").Select
    Cells.Select

    Selection.EntireColumn.Hidden = False
    Selection.EntireRow.Hidden = False
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    'gt sekmesine geç, filtre temizle ve satır sütunlarda gizlenenleri aç
    
    x = Range("$A$2").Row
    y = Range("$FI$" & sh).Column
    
    w = Range("$G$2").Row
    q = Range("$CI$" & sh).Column

    Sheets("gt").Select
Range("A2").AutoFilter 1, "T"
Range("a2").AutoFilter 5, "<>İhale Edilmesi Planlanıyor"

    'gt sekmesinde boş olanları gösterme şeklinde filtrele (burada T yi göster oluyor)

    Range("A:F,M:Q,U:U,W:W,Y:Z,AB:AB,AE:AF,AH:AI,AU:CH,CJ:KL").Select
    Selection.EntireColumn.Hidden = True
    'SÜTUNLARI SEÇ VE GİZLE
    
    ActiveSheet.PageSetup.PrintArea = "$G$2:$CI$" & sh
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
       Application.PrintCommunication = False
    ActiveSheet.PrintOut Copies:=xy
    
    With ActiveSheet
DateString = Format(Now, "dd-mm-yyyy hh-mm-ss")
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="Z:\A\B\C\D\" & DateString1 & "\" & "İlr_" & DateString & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
    

 End With
    Cells.Select
    Selection.EntireColumn.Hidden = False


    Range("A:F,I:ax,CJ:KP").Select
    Selection.EntireColumn.Hidden = True
    'SÜTUNLARI SEÇ VE GİZLE
    
  End With
    ActiveSheet.PageSetup.PrintArea = "$G$2:$CI$" & sh
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
       Application.PrintCommunication = False
    ActiveSheet.PrintOut Copies:=xy
    
    With ActiveSheet
DateString = Format(Now, "dd-mm-yyyy hh-mm-ss")
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="Z:\A\B\C\D\" & DateString1 & "\" & "KKK_" & DateString & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False



End With
  Sheets("EK").Select
    With ActiveSheet.PageSetup
    .PrintQuality = 600
    .Orientation = xlLandscape
    .PaperSize = xlPaperA3
    .FitToPagesWide = 1
    Application.PrintCommunication = False
    ActiveSheet.PrintOut Copies:=xy
 
With ActiveSheet
DateString = Format(Now, "dd-mm-yyyy hh-mm-ss")
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="Z:\A\B\C\D\" & DateString1 & "\" & "EK_" & DateString & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False



End With
End With
End With

  End With
    Sheets("GT").Select
    Cells.Select
    Selection.EntireColumn.Hidden = False
    Selection.EntireRow.Hidden = False
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    Range("G3").Select
    MsgBox "Rapor Yazıldı. Yazıcıya Gidebilirsin...", vbInformation
    MsgBox "Z:\A\B\C\D\bugünün tarihi olan klasörde pdf leri bulabilirsiniz...", vbInformation

End Sub
 
Kodlarınızdaki şu satırın altına DateString1 = Format(Now, "dd-mm-yyyy")

Aşağıdaki kodları ekleyiniz.

Kod: 
    If Dir("Z:\A\B\C\D\" & DateString1, vbDirectory) <> "" Then
        MsgBox "Aynı isimle klasör var, klasör oluşturulamadı...", vbCritical
        Exit Sub
    End If
 
Kod: 
Sub raporyaz()
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
DateString1 = Format(Now, "dd-mm-yyyy")
 If Dir("Z:\_a\b\c\d\e\" & DateString1, vbDirectory) <> "" Then
    MsgBox "Aynı İsimde Klasör var, klasör oluşturulamıyor... Mevcut Klasörün İsmini Değiştirerek Tekrar Deneyiniz...", vbCritical
    Exit Sub
    End If
ds.CreateFolder "Z:\_a\b\c\d\e\" & DateString1
    xy = InputBox("KAÇ KOPYA OLACAK")
        If xy = "" Then
    MsgBox "başlangıç hücresini yazmadınız.", vbCritical, "        Uyarı"
    Exit Sub
    End If
 sh = InputBox("GT sekmesinde çıktı alınacak son satır sayısı (harfsiz)")
    If sh = "" Then
MsgBox "son satır numarasını yazmadınız.", vbCritical, "        Uyarı"
Exit Sub
End If
.
.
.
.

If Dir("Z:\_a\b\c\d\e\" & DateString1, vbDirectory) <> "" Then
MsgBox "Aynı İsimde Klasör var, klasör oluşturulamıyor... Mevcut Klasörün İsmini Değiştirerek Tekrar Deneyiniz...", vbCritical

bu kısmı "Aynı isimde klasör var, mevcut klasörü silmek istermisiniz?" msgbox ile evet hayır seçenekleri ekleyerek evet seçilmesi durumunda o klasörün silinerek işlemlerin devam etmesi, hayır dersek işlemden çıkılması ve klasörün açılması için ne yapmalıyım?
 
Deneyiniz.

Kod: 
If Dir("Z:\_a\b\c\d\e\" & DateString1, vbDirectory) <> "" Then
    Onay =MsgBox"Aynı isimde klasör var, mevcut klasörü silmek ister misiniz?", vbCritical + vbYesNo)

    If Onay = vbYes Then
       CreateObject("Scripting.FileSystemObject").DeleteFolder ""Z:\_a\b\c\d\e\" & DateString1"
    Else
       Exit Sub
    End If
End If
 
Korhan Ayhan' Alıntı:
Deneyiniz.

Kod: 
If Dir("Z:\_a\b\c\d\e\" & DateString1, vbDirectory) <> "" Then
    Onay =MsgBox"Aynı isimde klasör var, mevcut klasörü silmek ister misiniz?", vbCritical + vbYesNo)

    If Onay = vbYes Then
       CreateObject("Scripting.FileSystemObject").DeleteFolder ""Z:\_a\b\c\d\e\" & DateString1"
    Else
       Exit Sub
    End If
End If
Genişletmek için tıkla ...

teşekkürler. evet oldu

Kod: 
.
.
.
End With
    Sheets("GT").Select
    Cells.Select
    Selection.EntireColumn.Hidden = False
    Selection.EntireRow.Hidden = False
    If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
    Range("G3").Select
    MsgBox "Rapor Yazıldı. Yazıcıya Gidebilirsin...", vbInformation
    MsgBox "Z:\_a\b\c\d\e\bugünün tarihi olan klasörde pdf leri bulabilirsiniz...", vbInformation
End Sub

bu kodun sonunda
MsgBox "Z:\_a\b\c\d\e\bugünün tarihi olan klasörde pdf leri bulabilirsiniz...", vbInformation kısmından sonra tamama bastığımızda klasörün açılması için ne ekleyebiliriz peki. yani şu klasör. Z:\_a\b\c\d\e\bugünün tarihi
 
end sub kısmının öncesine Shell "explorer Z:\a\b\c\d\e\" & DateString1, vbNormalFocus şeklinde kod ekliyorum ama e klasörü açılıyor. tanımlı olan DateString1 e karşılık gelen bugünün tarihi klasörünün içine giremedim bir türlü. tırnaklarla ilgili sorun yaşıyorum sanırım.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst