• DİKKAT

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

Toplu izin formu oluştur, tek dosyada PDF kaydet

D

denese

Katılım
17 Mart 2011
Mesajlar
441
Excel Vers. ve Dili
Office 2019
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

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
 
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

  • görüntü.jpg
    görüntü.jpg
    16.4 KB · Görüntüleme: 8
  • İzin Formu.xlsm
    İzin Formu.xlsm
    38.5 KB · Görüntüleme: 19
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

Ayrıca bilgisayarınızda yüklü bir yazıcı olmalı
 
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

  • görüntü1.jpg
    görüntü1.jpg
    16.4 KB · Görüntüleme: 5
  • görüntü2.jpg
    görüntü2.jpg
    15.3 KB · Görüntüleme: 3
  • görüntü3.jpg
    görüntü3.jpg
    20.4 KB · Görüntüleme: 3
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
 
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.
 
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:
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:
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

  • 22905.jpg
    22905.jpg
    178.2 KB · Görüntüleme: 7
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
 
Tek sayfalık tek bir pdf kayıt etti Halit bey. Oluşan dosya ekte yer alıyor.
 

Ekli dosyalar

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 )
 
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:
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:
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.
 
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.
Geri
Üst