• DİKKAT

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

Seçilen Sayfaları PDF Olarak Yazdırma

R

Rizelli3

Katılım
1 Mart 2017
Mesajlar
101
Excel Vers. ve Dili
Microsoft Office 2015
Türkçe
Merhabalar,

Örnekte bulunan dosyada gösterildiği gibi seçilen sayfaları macro ile PDF olarak yazdırmak ve dosyanın bulunduğu klasörün içerisine yeni bir klasör açarak içerisine atmasnı istiyorum bu mümkün müdür.

Şimdiden teşekkürler.

http://dosya.co/cs9ejyw1jl7l/ÖRNEK.xlsm.html
 

Ekli dosyalar

kod:

Kod: 
Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ReDim kontrol1(65000)

For m = 1 To Cells(Rows.Count, "c").End(3).Row
kontrol1(m) = 0
Next

For i = 2 To Cells(Rows.Count, "h").End(3).Row
bulunan = Cells(i, "h").Value
For j = 1 To ActiveWorkbook.Sheets.Count
aranan = Sheets(j).Name
If aranan = bulunan Then
kontrol1(i) = 1
Exit For
End If

Next j
Next i

say1 = 0
say2 = 0

For i = 2 To Cells(Rows.Count, "h").End(3).Row
If kontrol1(i) = 1 Then
say1 = say1 + 1
say2 = say1
If say1 = 1 Then
ThisWorkbook.Sheets(Cells(i, "h").Value).Copy
Else
ThisWorkbook.Sheets(Cells(i, "h").Value).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
End If

End If
Next i

If say2 > 0 Then
ActiveWorkbook.Worksheets.Select

yol = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files.Count

ad = ThisWorkbook.Path & "\pdf dosyası " & yol
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

say = CreateObject("Scripting.FileSystemObject").GetFolder(ad).Files.Count + 1

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\pdf dosyası " & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
End If
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub


kod2

Kod: 
Sub tobloları_pdf_yap2()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


say1 = 0


For i = 2 To ThisWorkbook.Sheets("ANASAYFA").Cells(Rows.Count, "h").End(3).Row
bulunan = ThisWorkbook.Sheets("ANASAYFA").Cells(i, "h").Value
For j = 1 To ThisWorkbook.Sheets.Count
aranan = ThisWorkbook.Sheets(j).Name
If aranan = bulunan Then

say1 = say1 + 1

If say1 = 1 Then
ThisWorkbook.Sheets(Cells(i, "h").Value).Copy
Else
ThisWorkbook.Sheets(Cells(i, "h").Value).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
End If

Exit For
End If

Next j
Next i


If say1 > 0 Then
ActiveWorkbook.Worksheets.Select

yol = CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders.Count + 1

ad = ThisWorkbook.Path & "\pdf dosyası " & yol
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

say = CreateObject("Scripting.FileSystemObject").GetFolder(ad).Files.Count + 1

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\pdf dosyası " & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
End If
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
Rizelli3' Alıntı:
Merhaba Halit Hocam,

Elinize kolunuza sağlık kodlar için ancak yeni bir dosya oluşturdum o kodları bu oluşturduğum dosyaya uyarlayabilir miyiz. örnek dosya ektedir.

tekrar teşekkür ederim.

http://dosya.co/rwjtmv0lgsbz/ÖRNEK.xlsm.html
Genişletmek için tıkla ...

Alıntı yazımı okuyun örnek dosyanız ile bu dosya çok farklı kodları yeniden yazmak gerekiyor.

Ben kodları yeniden yazdım.
yeni bir userform oluşturun içinede

1 adet ListBox1 nesnesi
1 adet CheckBox1 nesnesi
1 adet CommandButton1 nesnesi

ekeleyin ve kodu çalıştırın.


kod:
Kod: 
Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub


Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


say1 = 0

Dim i As Integer
son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If


For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then

say1 = say1 + 1
If say1 = 1 Then
ThisWorkbook.Sheets(ListBox1.List(i - 1)).Copy

ActiveSheet.DrawingObjects.Delete
Else
ThisWorkbook.Sheets(ListBox1.List(i - 1)).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
ActiveSheet.DrawingObjects.Delete

End If

End If
Next


If say1 > 0 Then
ActiveWorkbook.Worksheets.Select

yol = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).SubFolders.Count + 1

ad = ThisWorkbook.Path & "\pdf dosyası " & yol
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

say = CreateObject("Scripting.FileSystemObject").getfolder(ad).Files.Count + 1

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\pdf dosyası " & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
End If
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1
For i = 1 To ActiveWorkbook.Sheets.Count
ListBox1.AddItem Sheets(i).Name

Next i
End Sub
 
halit3' Alıntı:
Alıntı yazımı okuyun örnek dosyanız ile bu dosya çok farklı kodları yeniden yazmak gerekiyor.

Ben kodları yeniden yazdım.
yeni bir userform oluşturun içinede

1 adet ListBox1 nesnesi
1 adet CheckBox1 nesnesi
1 adet CommandButton1 nesnesi

ekeleyin ve kodu çalıştırın.


kod:
Kod: 
Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub


Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


say1 = 0

Dim i As Integer
son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If


For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then

say1 = say1 + 1
If say1 = 1 Then
ThisWorkbook.Sheets(ListBox1.List(i - 1)).Copy

ActiveSheet.DrawingObjects.Delete
Else
ThisWorkbook.Sheets(ListBox1.List(i - 1)).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
ActiveSheet.DrawingObjects.Delete

End If

End If
Next


If say1 > 0 Then
ActiveWorkbook.Worksheets.Select

yol = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path).SubFolders.Count + 1

ad = ThisWorkbook.Path & "\pdf dosyası " & yol
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

say = CreateObject("Scripting.FileSystemObject").getfolder(ad).Files.Count + 1

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\pdf dosyası " & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
End If
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1
For i = 1 To ActiveWorkbook.Sheets.Count
ListBox1.AddItem Sheets(i).Name

Next i
End Sub
Genişletmek için tıkla ...

Halit Hocam öncelikle çok teşekkür ederim. Dediğiniz gibi yapıp kodları işledim. Sayfaları ayrı ayrı kendi sayfa adıyla excelin bulunduğu klasörün içerisine FATURA adında yeni bir klasör açarak içerisine atması mümkün müdür.

elinize kolunuza sağlık yardımlarınız için çok teşekkür ederim.
 
Rizelli3' Alıntı:
Halit Hocam öncelikle çok teşekkür ederim. Dediğiniz gibi yapıp kodları işledim. Sayfaları ayrı ayrı kendi sayfa adıyla excelin bulunduğu klasörün içerisine FATURA adında yeni bir klasör açarak içerisine atması mümkün müdür.

elinize kolunuza sağlık yardımlarınız için çok teşekkür ederim.
Genişletmek için tıkla ...

CommandButton1_Click kodunu aşağıdaki ile değiştir.


Kod: 
Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

say1 = 0

Dim i As Integer
son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If

ad = ThisWorkbook.Path & "\FATURA"
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

Say = CreateObject("Scripting.FileSystemObject").getfolder(ad).Files.Count + 1

For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
sayfa = ListBox1.List(i - 1)

If WorksheetFunction.CountA(Sheets(sayfa).Cells) > 0 Then
ActiveWorkbook.Sheets(sayfa).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\" & sayfa & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
End If
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True


MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
halit3' Alıntı:
CommandButton1_Click kodunu aşağıdaki ile değiştir.


Kod: 
Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

say1 = 0

Dim i As Integer
son = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If

ad = ThisWorkbook.Path & "\FATURA"
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

Say = CreateObject("Scripting.FileSystemObject").getfolder(ad).Files.Count + 1

For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
sayfa = ListBox1.List(i - 1)

If WorksheetFunction.CountA(Sheets(sayfa).Cells) > 0 Then
ActiveWorkbook.Sheets(sayfa).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\" & sayfa & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
End If
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True


MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
Genişletmek için tıkla ...



Halit Hocam,

dediklerinizi yaptım ancak aşağıdaki hatayı alıyorum. Bu kadar yardımcı olduğunuz için çok sağ olun. Ne kadar teşekkür etsem azdır.

V0M8Ev.jpg


Debug'a tıkladığımda;

qbWQEZ.jpg
 
Devredilen izinlerle alakalı bir durum
Dosyayı hangi klasörde çalıştırıyorsunuz bilmiyorum muhtemelen c sürücüsü içinde çalıştırıyorsunuz bilgisayarınızda d sürücüsü varsa dosyayı oraya alın ve çalıştırın yada dosyayı çalıştırdığınız sürücüye sağ tıklayın
özellikler/güvenlik kullanıcı guruplarında bilgisayar kullanıcı ismini seçin ve gelişmiş seçeneğini tıklayın oranda kullanıcı adını bulun ve seçin daha sonraki açılan pencereden de aynı işlemi yapın düzenle seçeneğini tıkla ve bütün tikleri seç tamam diyin (tüm bağımlı nesne izinlerini bu nesneden devralınabilen izinlerle değiştir) seçeneğini tikle ve uygula de

Yapmış olduğun işlemle ilgili izin bölümünde tam denetim yazarsa bu işlem olmuş demektir.
bilgisayarı kapat yeniden aç

Eğer kısıtlı bilgisayarda bu işlemleri yapacaksanız belkide yaptırmayacaktır.

aşağıdaki linki irdeleyiniz.
https://answers.microsoft.com/tr-tr...db?msgId=d426fc29-4a2e-4f1f-83ae-1e7db4a44bf9


http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim1.jpg

http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim2.jpg

http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim3.jpg

http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim4.jpg
 
halit3' Alıntı:
Devredilen izinlerle alakalı bir durum
Dosyayı hangi klasörde çalıştırıyorsunuz bilmiyorum muhtemelen c sürücüsü içinde çalıştırıyorsunuz bilgisayarınızda d sürücüsü varsa dosyayı oraya alın ve çalıştırın yada dosyayı çalıştırdığınız sürücüye sağ tıklayın
özellikler/güvenlik kullanıcı guruplarında bilgisayar kullanıcı ismini seçin ve gelişmiş seçeneğini tıklayın oranda kullanıcı adını bulun ve seçin daha sonraki açılan pencereden de aynı işlemi yapın düzenle seçeneğini tıkla ve bütün tikleri seç tamam diyin (tüm bağımlı nesne izinlerini bu nesneden devralınabilen izinlerle değiştir) seçeneğini tikle ve uygula de

Yapmış olduğun işlemle ilgili izin bölümünde tam denetim yazarsa bu işlem olmuş demektir.
bilgisayarı kapat yeniden aç

Eğer kısıtlı bilgisayarda bu işlemleri yapacaksanız belkide yaptırmayacaktır.

aşağıdaki linki irdeleyiniz.
https://answers.microsoft.com/tr-tr...db?msgId=d426fc29-4a2e-4f1f-83ae-1e7db4a44bf9


http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim1.jpg

http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim2.jpg

http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim3.jpg

http://www.cemvenuray.com/Personal/Microsoft/Microsoft_yardim4.jpg
Genişletmek için tıkla ...


Çok teşekkürler hocam elinize kolunuza sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst