Toplu izin formu oluştur, tek dosyada PDF kaydet

D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Merhaba,

Ekteki izin formu dosyasında, Data sayfasındaki personel bilgilerini kaynak göstererek makro ile tüm kişiler için ayrı ayrı izin formu oluşturup toplu çıktı alabiliyorum.

Yapmak istediğim; ayrı bir makro atayarak tüm kişiler için yine ayrı ayrı oluşacak izin formlarını, tek bir dosyada pdf formatında farklı kaydetmesini, kayıt yerini Gözat ile sormasını istiyorum.

Saygılar, selamlar
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kod:

Kod: 
Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
sayfa = ActiveSheet.Name

say = 0
For i = 2 To ThisWorkbook.Sheets("T.Data").[A65536].End(xlUp).Row
say = say + 1
ThisWorkbook.Sheets(sayfa).Range("BI4:BI12").ClearContents

'---  PERSONEL BİLGİLERİ   ---
ThisWorkbook.Sheets(sayfa).Cells(4, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 3).Value
ThisWorkbook.Sheets(sayfa).Cells(5, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 1).Value
ThisWorkbook.Sheets(sayfa).Cells(6, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 2).Value
ThisWorkbook.Sheets(sayfa).Cells(7, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 4).Value
ThisWorkbook.Sheets(sayfa).Cells(8, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 5).Value
ThisWorkbook.Sheets(sayfa).Cells(9, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 6).Value
ThisWorkbook.Sheets(sayfa).Cells(10, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 7).Value
ThisWorkbook.Sheets(sayfa).Cells(11, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 8).Value
ThisWorkbook.Sheets(sayfa).Cells(12, 61).Value = ThisWorkbook.Sheets("T.Data").Cells(i, 9).Value

'-----------------------------  YAZICIYA   -----------------------------------
'ActiveWindow.SelectedSheets.PrintOut Copies:=1

If say = 1 Then
ThisWorkbook.Sheets(sayfa).Copy
'GoTo atla
Else
ThisWorkbook.Sheets(sayfa).Copy After:=ActiveWorkbook.Sheets(1)
say1 = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say1)
End If

Next i

If say > 0 Then
ActiveWorkbook.Worksheets.Select
'Application.DisplayAlerts = False
yol = ThisWorkbook.Path
say2 = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files.Count + 1

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & "\pdf dosyası " & say2 & ".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
 
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Sn Halit3, desteğiniz için çok teşekkürler, ancak kodu farklı bir modüle uyguladığımda, kayıt için gözat penceresi yerine yazıcı seçenekleri çıkıyor, sonrasında ise hata veriyor.
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
kayıtı dosyanın yanına yapıyor sürücü de kısıtlama yoksa kayıt yapıyor.
yapılan bir kayıtı ekliyorum.

2 nolu mesajdaki kodu güncelledim
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Ayrıca bilgisayarınızda yüklü bir yazıcı olmalı
 
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Halit Bey,

Excel dosyası masaüstünde yer alıyor. Bilgisayarıma bağlı olan ya da ağda yer alan herhangi bir yazıcı bulunmuyor. Sürücüde herhangi bir kısıtlama olmadığını düşünüyorum ancak bilmediğim atladığım bir başka durum olabilir.

Ekteki görüntü1 penceresine "İptal" dediğimde, görüntü2 deki hatayı alıyorum. görüntü3 de ise hata içeriği yer alıyor.
 

Ekli dosyalar

D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Sayın halit3,

Kodu, yazıcı tanımlı ofis bilgisayarımda denedim ve sonuç kusursuz. Yardım ve destekleriniz için çok teşekkür ediyorum.

İyi çalışmalar
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
denese' Alıntı:
Sayın halit3,

Kodu, yazıcı tanımlı ofis bilgisayarımda denedim ve sonuç kusursuz. Yardım ve destekleriniz için çok teşekkür ediyorum.

İyi çalışmalar
Genişletmek için tıkla ...
Yazıcı olmayan bilgisayara sanal herhangi bir yazıcı yükle orada da çalışacaktır.
 
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Merhaba,

Ekteki çalışmada, sicil numarasına göre kullanılan izinleri listeliyorum. Yapmak istediğim;

"Liste" sayfasındaki sicil numaralarına göre "Mutabakat" sayfasında izinleri listeleyerek, Hedef yolu C:\Dosyalar olacak şekilde klasör oluşturup, bu klasör içine her sicil için ayrı ayrı PDF kayıt yapmak istiyorum . Oluşturulacak PDF dosya adları yine sicil numaraları olmalı.

Yardımcı olabilir misiniz.
 

Ekli dosyalar

Son düzenleme:
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu bir dene

Kod: 
Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
sayfa = ActiveSheet.Name

yol = "C:\Dosyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(yol) = False Then
MkDir yol
End If
isim = ThisWorkbook.Sheets(sayfa).Cells(3, 2).Value

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

'MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
Son düzenleme:
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Halit hocam desteğiniz için çok teşekkür ediyorum. Kod, C sürücüsünde oluşturduğu Dosyalar klasörü içerisine tek bir PDF kaydetti. Dosya boyutu çok yüksek olduğu için ekran görüntüsünü ekleyebildim. Tekrar yardımcı olabilir misiniz.
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu dene
Kod: 
Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
sayfa = ActiveSheet.Name

yol = "C:\Dosyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(yol) = False Then
MkDir yol
End If
isim = ThisWorkbook.Sheets(sayfa).Cells(3, 2).Value

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

'MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Tek sayfalık tek bir pdf kayıt etti Halit bey. Oluşan dosya ekte yer alıyor.
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
denese' Alıntı:
Merhaba,

Ekteki çalışmada, sicil numarasına göre kullanılan izinleri listeliyorum. Yapmak istediğim;

"Liste" sayfasındaki sicil numaralarına göre "Mutabakat" sayfasında izinleri listeleyerek, Hedef yolu C:\Dosyalar olacak şekilde klasör oluşturup, bu klasör içine her sicil için ayrı ayrı PDF kayıt yapmak istiyorum . Oluşturulacak PDF dosya adları yine sicil numaraları olmalı.

Yardımcı olabilir misiniz.
Genişletmek için tıkla ...
11 nolu mesajınız da bu yazıyor
(her sicil için ayrı ayrı PDF kayıt yapmak istiyorum )
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Toplu için belki böyle olabilir
Kodları silin ve bu kodları ekleyin deneme yapın

Kod: 
Sub Mutabakat_Listele()
Dim s1 As Worksheet, s2 As Worksheet, a(), b()
Dim t1 As Date, t2 As Date, sicil As String
    Set s1 = Sheets("Data")
    Set s2 = Sheets("Mutabakat")
    t1 = s2.[F5]: t2 = s2.[F6]: sicil = s2.[h3]
    a = s1.Range("A2:J" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    ReDim b(1 To UBound(a), 1 To 6)
        For i = 1 To UBound(a)
            If CStr(a(i, 1)) = sicil Then
                If a(i, 7) >= t1 And a(i, 8) <= t2 Then
                    Say = Say + 1
                    b(Say, 1) = a(i, 4)
                    b(Say, 2) = a(i, 5)
                    b(Say, 3) = a(i, 7)
                    b(Say, 4) = a(i, 8)
                    b(Say, 5) = a(i, 9)
                    b(Say, 6) = a(i, 10)
                End If
            End If
        Next i
    s2.Range("A22:F" & Rows.Count).ClearContents
    If Say > 0 Then
        s2.[B22].Resize(Say).NumberFormat = "@"
        s2.[C22].Resize(Say, 3).NumberFormat = "dd.mm.yyyy"
        s2.[F22].Resize(Say).NumberFormat = "#,##0.00"
        s2.[A22].Resize(Say, 6) = b
    End If
 
'MsgBox "İşlem bitti.", vbInformation
End Sub


Sub Sil_2()
ActiveSheet.Range("A22:F1000").ClearContents
End Sub

Sub tobloları_pdf_yap()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
sayfa = ActiveSheet.Name

Yol = "C:\Dosyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(Yol) = False Then
MkDir Yol
End If

For r = 1 To Sheets("Liste").Cells(Rows.Count, "a").End(3).Row  
Mutabakat_Listele
ThisWorkbook.Sheets(sayfa).Cells(3, 2).Value = ThisWorkbook.Sheets("Liste").Cells(r, 1).Value
isim = ThisWorkbook.Sheets(sayfa).Cells(3, 2).Value
ThisWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next r

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
Son düzenleme:
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,798
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Yukarıdaki kod olmaz ise bunu kullan
Kod: 
Sub Mutabakat_Listele()
Dim s1 As Worksheet, s2 As Worksheet, a(), b()
Dim t1 As Date, t2 As Date, sicil As String
    Set s1 = Sheets("Data")
    Set s2 = Sheets("Mutabakat")
    t1 = s2.[F5]: t2 = s2.[F6]: sicil = s2.[h3]
    a = s1.Range("A2:J" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    ReDim b(1 To UBound(a), 1 To 6)
        For i = 1 To UBound(a)
            If CStr(a(i, 1)) = sicil Then
                If a(i, 7) >= t1 And a(i, 8) <= t2 Then
                    Say = Say + 1
                    b(Say, 1) = a(i, 4)
                    b(Say, 2) = a(i, 5)
                    b(Say, 3) = a(i, 7)
                    b(Say, 4) = a(i, 8)
                    b(Say, 5) = a(i, 9)
                    b(Say, 6) = a(i, 10)
                End If
            End If
        Next i
    s2.Range("A22:F" & Rows.Count).ClearContents
    If Say > 0 Then
        s2.[B22].Resize(Say).NumberFormat = "@"
        s2.[C22].Resize(Say, 3).NumberFormat = "dd.mm.yyyy"
        s2.[F22].Resize(Say).NumberFormat = "#,##0.00"
        s2.[A22].Resize(Say, 6) = b
    End If

'MsgBox "İşlem bitti.", vbInformation
End Sub


Sub Sil_2()
ActiveSheet.Range("A22:F1000").ClearContents
End Sub

Sub tobloları_pdf_yap()

'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
sayfa = ActiveSheet.Name

Yol = "C:\Dosyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(Yol) = False Then
MkDir Yol
End If

For r = 1 To Sheets("Liste").Cells(Rows.Count, "a").End(3).Row 

ThisWorkbook.Sheets(sayfa).Cells(3, "H").Value = ThisWorkbook.Sheets("Liste").Cells(r, 1).Value
isim = ThisWorkbook.Sheets(sayfa).Cells(3, "H").Value
Mutabakat_Listele
ThisWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next r

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
 
Son düzenleme:
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
halit3' Alıntı:
Yukarıdaki kod olmaz ise bunu kullan
Kod: 
Sub Mutabakat_Listele()
Dim s1 As Worksheet, s2 As Worksheet, a(), b()
Dim t1 As Date, t2 As Date, sicil As String
    Set s1 = Sheets("Data")
    Set s2 = Sheets("Mutabakat")
    t1 = s2.[F5]: t2 = s2.[F6]: sicil = s2.[h3]
    a = s1.Range("A2:J" & s1.Cells(Rows.Count, 1).End(3).Row).Value
    ReDim b(1 To UBound(a), 1 To 6)
        For i = 1 To UBound(a)
            If CStr(a(i, 1)) = sicil Then
                If a(i, 7) >= t1 And a(i, 8) <= t2 Then
                    Say = Say + 1
                    b(Say, 1) = a(i, 4)
                    b(Say, 2) = a(i, 5)
                    b(Say, 3) = a(i, 7)
                    b(Say, 4) = a(i, 8)
                    b(Say, 5) = a(i, 9)
                    b(Say, 6) = a(i, 10)
                End If
            End If
        Next i
    s2.Range("A22:F" & Rows.Count).ClearContents
    If Say > 0 Then
        s2.[B22].Resize(Say).NumberFormat = "@"
        s2.[C22].Resize(Say, 3).NumberFormat = "dd.mm.yyyy"
        s2.[F22].Resize(Say).NumberFormat = "#,##0.00"
        s2.[A22].Resize(Say, 6) = b
    End If

'MsgBox "İşlem bitti.", vbInformation
End Sub


Sub Sil_2()
ActiveSheet.Range("A22:F1000").ClearContents
End Sub

Sub tobloları_pdf_yap()

'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
sayfa = ActiveSheet.Name

Yol = "C:\Dosyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(Yol) = False Then
MkDir Yol
End If

For r = 1 To Sheets("Liste").Cells(Rows.Count, "a").End(3).Row
Mutabakat_Listele
ThisWorkbook.Sheets(sayfa).Cells(3, "H").Value = ThisWorkbook.Sheets("Liste").Cells(r, 1).Value
isim = ThisWorkbook.Sheets(sayfa).Cells(3, "H").Value
ThisWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next r

MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub
Genişletmek için tıkla ...
Tam istediğim gibi oldu Halit Hocam. Emeğinize, gönlünüze sağlık. Çok teşekkürler.
 
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
439
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
Halit hocam kusura bakmayın, kaydedilen PDF' lerde şöyle bir şey fark ettim ve bir türlü çözemedim. Umarın yazıya dökebilirim;

A2 hücresindeki sicil adıyla oluşan PDF' de izinler listelenmemiş oluyor. Bir de örneğin; Liste sayfasında A3 hücresindeki sicil adıyla oluşan PDF, A4 hücresindeki sicilin izinlerini listeliyor ve sayfadaki tüm sicillerde böyle bir döngü oluyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst