Koşullu ve Birleştirerek Pdf Kaydetme

ofd2008 · 31 Mart 2015

Merhaba,
Aşağıdaki kodlama ile farklı sayfalardaki tabloları pdf ye dönüştürebiliyorum. Ancak eklemek istediğim bir kaç özellik var.
- Çıktı sayfasında onay kutusu seçili olanların pdf çıktı olarak vermesini eklemek
- Her tablo için ayrı bir sayfa oluşturuyor, tablolar sığdığı takdirde aynı sayfada olabilir.
- Ölçeklendirmeyi manuel girdim, bunu sayfaya otomatik sığdıracak şekilde yapılabilir mi?
- Son olarak dönüştürme işlemi hızlandırılabilir mi?
Örnek Dosya Linki
Kodlama:

Kod:

Sub pdfdonustur()
Dim Yol As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Yol = ThisWorkbook.Path
Say = ThisWorkbook.Name

With Sheets("1").PageSetup
.PrintArea = "$B$3:$I$20,$K$3:$R$20,$B$23:$I$40,$K$23:$R$40"
.Orientation = xlPortrait
.BlackAndWhite = True
.Zoom = 100
End With
With Sheets("2").PageSetup
.PrintArea = "$B$2:$I$19,$B$22:$I$39,$K$2:$R$19,$K$22:$R$39,$T$2:$AA$19,$T$22:$AA$39"
.Orientation = xlPortrait
.BlackAndWhite = True
.Zoom = 100
End With
With Sheets("3").PageSetup
.PrintArea = "$B$2:$X$37"
.Orientation = xlLandscape
.BlackAndWhite = True
.Zoom = 60
End With
With Sheets("4").PageSetup
.PrintArea = "$B$2:$X$37"
.Orientation = xlLandscape
.BlackAndWhite = True
.Zoom = 60
End With
Sheets(Array("1", "2", "3", "4")).Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & Say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "İşlem tamamlandı."

End Sub

Onay kutusu için bu tarz bir kodu entegre etmeye çalıştım ama başaramadım.

Kod:

    If Sheets("Çıktı").CheckBoxes("Check Box 2") = 1 Then
        Çıktı makro kodu
    Else
    End If

Saygılarımla
Yardımlarınız için teşekkürler.

halit3 · 31 Mart 2015

(Dosya linki) nden dosyanız inmiyor üyelik istiyor ve çeşitli yönlerdirmeler çıkıyor

excel_ance · 31 Mart 2015

hocam dosyayı ben yüklüyorum

halit3' Alıntı:
(Dosya linki) nden dosyanız inmiyor üyelik istiyor ve çeşitli yönlerdirmeler çıkıyor

hocam dosyayı yükledim

halit3 · 1 Nisan 2015

excel_ance' Alıntı:
hocam dosyayı yükledim

açıklama

1-g sütununa sayfa adı yazılır
2-h sütununa pdf yapılacak sayfadaki adresler yazılır.
3-b sutünuna bilgi amaçlı tablo adları yazılır
4-nesle sil düğmesine tıklanır
5-nesne ekle düğmesine tıklanır
6-4 ve 5 seçenekler tablolarda ekleme veya silindikten sonra ihtiyaç olduğu zaman bir sefer yapmak yeterlidir.

7-seçenek düğmelerinden seçerek tıklanılır
8-pdf aktar düğmesine tıklanılır.

ofd2008 · 1 Nisan 2015

Hocam, üyelik durumundan dolayı indiremiyorum, harici link verebilir misiniz?

excel_ance · 1 Nisan 2015

http://s2.dosya.tc/server2/ar0bc3/ornk222.rar.html dosyanız burada. kolay gelsin

ofd2008 · 1 Nisan 2015

Yardımlarınız için çok teşekkür ederim.
Halit Bey sistem çok güzel çalışıyor, elinize kolunuz sağlık.

Her tablo için ayrı sayfa yerine, aynı sayfa içerisinde birden fazla tablo sığıyorsa yazdırılabilecek şekilde düzenlenebilir mi?
Saygılarımla.

excel_ance · 1 Nisan 2015

halit hocam teşekkür ederim ellerinize sağlık

halit3 · 1 Nisan 2015

ofd2008' Alıntı:
Yardımlarınız için çok teşekkür ederim.
Halit Bey sistem çok güzel çalışıyor, elinize kolunuz sağlık.

Her tablo için ayrı sayfa yerine, aynı sayfa içerisinde birden fazla tablo sığıyorsa yazdırılabilecek şekilde düzenlenebilir mi?
Saygılarımla.

PDF formatları böyle oluyor

ancak

B3:I20
B23:I40

Yazdırma alanları ile ilgili yukarıdaki bölümün yerine aşağıdaki gibi birleştirirseniz herhalde tek sayfada yazdırılacaktır.

B3:I40

excel_ance · 1 Nisan 2015

hocam teşekkür ediyorum.

halit3 · 1 Nisan 2015

4 nolu mesajdaki dosyaya Data sayfası ekleyerek bu kodu da kullanabilirsiniz.

Kod:

Sub pdfaktar2()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
sat = 1

Sheets("Data").Range(Sheets("Data").Cells(1, 1), Sheets("Data").Cells(Rows.Count, Columns.Count)).ClearContents
Sheets("Data").Rows("1:" & Rows.Count).Interior.ColorIndex = xlNone

yer = ActiveSheet.Name
Set s1 = Sheets(yer)

For m = 2 To s1.Cells(Rows.Count, "g").End(3).Row
s1.Cells(m, "f") = ""
Next m

Dim Picture As Object

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn Then
Say = Picture.BottomRightCell.Row
s1.Cells(Say, "f") = "Evet"
End If
End If
Next Picture

sut = "g"
For r = 2 To s1.Cells(Rows.Count, "g").End(3).Row
aranan = s1.Cells(r, sut)

If WorksheetFunction.CountIf(Range("g2:g" & r), aranan) = 1 Then

For i = r To s1.Cells(Rows.Count, "g").End(3).Row
If s1.Cells(i, "f") = "Evet" Then
If aranan = s1.Cells(i, sut) Then

Sheets(s1.Cells(i, sut)).Range(s1.Cells(i, "h")).Copy

Sheets("Data").Range("A" & sat).PasteSpecial Paste:=3
sat = Sheets("Data").Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

End If
End If
Next i

End If
Next r


Yol = ThisWorkbook.Path
Say = CreateObject("Scripting.FileSystemObject").getfolder(Yol).Files.Count + 1

Sheets("data").ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & Say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Application.ScreenUpdating = True
Application.DisplayAlerts = True

Sheets(yer).Select
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "

End Sub

ofd2008 · 23 Temmuz 2015

Halit Hocam, bu kodlama içerisine bazı hücreler sayfa dışına taştıkları için ölçekleme de (zoom özelliği) ekleyebili miyiz? Hücre adresi girilen sütun gibi yanına ölçekleme için bir sutun açılıp değerleri okutabilirseniz çok iyi olacak.
Saygılarımla.
Hayırlı Günler.

halit3 · 23 Temmuz 2015

ofd2008' Alıntı:
Halit Hocam, bu kodlama içerisine bazı hücreler sayfa dışına taştıkları için ölçekleme de (zoom özelliği) ekleyebili miyiz? Hücre adresi girilen sütun gibi yanına ölçekleme için bir sutun açılıp değerleri okutabilirseniz çok iyi olacak.
Saygılarımla.
Hayırlı Günler.

Tam olarak ne dediğinizi anlamadım ama örnek dosyada çıktı sayfasındaki H sütunundaki hücre adreslerini büyutmek lazım.

örnek
K3:R20 bunu

K2:R21 veya J2:S251 gibi

ofd2008 · 27 Temmuz 2015

Hocam, örnek dosyada şimdi fark ettim. Tablo aralığı geniş ilgili sayfada sığdırmak için ölçeklendirme yapmışsınız. Buna göre düzenleyince sorun çözüldü. Teşekkür ederim. Hayırlı günler.

karakaçan · 28 Temmuz 2015

makro hata veriyor

arkadaşlar bu dosyayı bende indirdim çalıştırınca aşağıdaki bölümde hata veriyor
invalid procedüre diyor.

neyi eksik yapıyorum

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & Say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True

halit3 · 28 Temmuz 2015

karakaçan' Alıntı:
arkadaşlar bu dosyayı bende indirdim çalıştırınca aşağıdaki bölümde hata veriyor
invalid procedüre diyor.

neyi eksik yapıyorum

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & Say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True

Aşağıdaki linkdeki eklentiyi yükleyip denermisiniz.

http://www.microsoft.com/tr-tr/download/details.aspx?id=9943

direk link

http://www.microsoft.com/tr-tr/download/confirmation.aspx?id=9943

ofd2008 · 29 Temmuz 2015

Halit Bey, kodlamanın çalışma prensibinde çözemediğim bir konu bulunuyor. Sadece bilgi almak öğrenmek için soruyorum.
Sayfalar sırayla 1,2,3,4,Çıktı şeklinde excel de yer alıyor. Çıktı,1,2,3,4 olarak çıktı sayfasını sol en başa aldığımda pdf aktarma işlemi doğru bir şekilde gerçekleşmiyor, bu kez hücrelerde belirtilen sayfaları tanımıyor çıktı sayfasını baz alıp yazılan hücrelerin çıktıları veriliyor.

halit3 · 29 Temmuz 2015

ofd2008' Alıntı:
Halit Bey, kodlamanın çalışma prensibinde çözemediğim bir konu bulunuyor. Sadece bilgi almak öğrenmek için soruyorum.
Sayfalar sırayla 1,2,3,4,Çıktı şeklinde excel de yer alıyor. Çıktı,1,2,3,4 olarak çıktı sayfasını sol en başa aldığımda pdf aktarma işlemi doğru bir şekilde gerçekleşmiyor, bu kez hücrelerde belirtilen sayfaları tanımıyor çıktı sayfasını baz alıp yazılan hücrelerin çıktıları veriliyor.

Bu kodu denermisiniz.

Kod:

Sub pdfaktar2()
'On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
yer = ActiveSheet.Name

Set s1 = Sheets(yer)
say3 = ActiveWorkbook.Sheets.Count
ReDim deg1(say3)
For j = 1 To say3
deg1(j) = Sheets(j).Name
Next



Set s1 = Sheets(yer)
For t = 2 To s1.Cells(Rows.Count, "g").End(3).Row
s1.Cells(t, "f") = ""
Next t


Dim Picture As Object

For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Value = xlOn Then
Say = Picture.BottomRightCell.Row
s1.Cells(Say, "f") = "Evet"
End If
End If
Next Picture

say2 = 0
sut = "g"
Dim myArray() As Variant
m = 0
For r = 2 To s1.Cells(Rows.Count, "g").End(3).Row
aranan3 = s1.Cells(r, sut)
Say = 0
deg2 = ""

If WorksheetFunction.CountIf(s1.Range("g2:g" & r), aranan3) = 1 Then

For i = r To s1.Cells(Rows.Count, "g").End(3).Row
If s1.Cells(i, "f") = "Evet" Then
If aranan3 = s1.Cells(i, sut) Then
Say = Say + 1

If Say = 1 Then
deg2 = s1.Cells(i, "h")
Else
deg2 = deg2 & "," & s1.Cells(i, "h")
End If
End If
End If
Next i

If deg2 <> "" Then



Sheets(aranan3).PageSetup.PrintArea = deg2
If IsNumeric(aranan3) = True Then aranan3 = "" & aranan3 & ""
say2 = say2 + 1
Sheets(aranan3).Move Before:=Sheets(say2)
ReDim Preserve myArray(m)
myArray(m) = aranan3
m = m + 1

End If
End If
Next r


If m = 0 Then Exit Sub
Sheets(myArray).Select

Dim Yol As String
Application.DisplayAlerts = False
Yol = ThisWorkbook.Path
Say = CreateObject("Scripting.FileSystemObject").getfolder(Yol).Files.Count + 1

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & Say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False



For j = 1 To say3
Sheets(deg1(j)).Move Before:=Sheets(j)
Next

Sheets(yer).Select

Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

karakaçan · 29 Temmuz 2015

benim sorunum çözüldü teşekkürler

ofd2008 · 30 Temmuz 2015

Halit bey teşekkür ederim.
Hayırlı Günler.

Koşullu ve Birleştirerek Pdf Kaydetme

ofd2008

halit3

Uzman

excel_ance

Ekli dosyalar

halit3

Uzman

Ekli dosyalar

ofd2008

excel_ance

ofd2008

excel_ance

halit3

Uzman

excel_ance

halit3

Uzman

ofd2008

halit3

Uzman

ofd2008

karakaçan

halit3

Uzman

ofd2008

halit3

Uzman

karakaçan

ofd2008