Toplu izin formu oluştur, tek dosyada PDF kaydet

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
18 nolu mesajdaki kodu düzelttim
 
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, emekleriniz çok büyük ve değerli. Tekrar çok teşekkür ediyorum.
 
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 Halit Hocam,

Data sayfasında A sütununda yer alan tüm sicil numaraları için ayrı ayrı PDF form oluşturarak yine C:\Dosyalar klasörüne kaydetmek istiyorum. Aşağıdaki şekilde formlar tek tek oluşuyor ve hedef dosyaya kayıt yapıyor. Ancak oluşan formlardaki isimler değişmiyor, hepsini aynı isimde kaydediyor. Buradaki döngü konusunda yardımcı olabilir misiniz.
Ekran Alıntısı.PNG
 

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:

Rich (BB code): 
Sub tumunu_ayri_ayri_pdf_kaydet()
If MsgBox("Data sayfasında A sütununda yer alan tüm sicil numaraları için ayrı ayrı form oluşturulacak ve C:\Dosyalar klasörüne kaydedilecek, Devam edilsin mi?", vbYesNo + vbQuestion, " UYARI ") = vbNo Then Exit Sub
'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 = 2 To Sheets("Data").Cells(Rows.Count, "a").End(3).Row

ThisWorkbook.Sheets(sayfa).Cells(1, "O").Value = ThisWorkbook.Sheets("Data").Cells(r, 1).Value
ThisWorkbook.Sheets(sayfa).Cells(2, "O").Value = ThisWorkbook.Sheets("Data").Cells(r, 2).Value
isim = ThisWorkbook.Sheets(sayfa).Cells(1, "O").Value

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

MsgBox "İşlem Tamamlandı.", vbInformation, " Uyarı "
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
halit3' Alıntı:
Kod:

Rich (BB code): 
Sub tumunu_ayri_ayri_pdf_kaydet()
If MsgBox("Data sayfasında A sütununda yer alan tüm sicil numaraları için ayrı ayrı form oluşturulacak ve C:\Dosyalar klasörüne kaydedilecek, Devam edilsin mi?", vbYesNo + vbQuestion, " UYARI ") = vbNo Then Exit Sub
'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 = 2 To Sheets("Data").Cells(Rows.Count, "a").End(3).Row

ThisWorkbook.Sheets(sayfa).Cells(1, "O").Value = ThisWorkbook.Sheets("Data").Cells(r, 1).Value
ThisWorkbook.Sheets(sayfa).Cells(2, "O").Value = ThisWorkbook.Sheets("Data").Cells(r, 2).Value
isim = ThisWorkbook.Sheets(sayfa).Cells(1, "O").Value

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

MsgBox "İşlem Tamamlandı.", vbInformation, " Uyarı "
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim hocam. Allah razı olsun.
 
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
Form sayfasına sicil bilgilerini getirmeden de kodu kullanabilirsiniz.
Kod: 
Sub tumunu_ayri_ayri_pdf_kaydet()
If MsgBox("Data sayfasında A sütununda yer alan tüm sicil numaraları için ayrı ayrı form oluşturulacak ve C:\Dosyalar klasörüne kaydedilecek, Devam edilsin mi?", vbYesNo + vbQuestion, " UYARI ") = vbNo Then Exit Sub
sayfa = ActiveSheet.Name

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

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

MsgBox "İşlem Tamamlandı.", vbInformation, " Uyarı "
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
halit3' Alıntı:
Form sayfasına sicil bilgilerini getirmeden de kodu kullanabilirsiniz.
Kod: 
Sub tumunu_ayri_ayri_pdf_kaydet()
If MsgBox("Data sayfasında A sütununda yer alan tüm sicil numaraları için ayrı ayrı form oluşturulacak ve C:\Dosyalar klasörüne kaydedilecek, Devam edilsin mi?", vbYesNo + vbQuestion, " UYARI ") = vbNo Then Exit Sub
sayfa = ActiveSheet.Name

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

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

MsgBox "İşlem Tamamlandı.", vbInformation, " Uyarı "
End Sub
Genişletmek için tıkla ...
Tekrar teşekkür ederim hocam, çok sağ olun.
 
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
Teşekkürler iyi çalışmalar
 
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 Halit Hocam,,

Yukarıdaki belirtiğiniz kodlar ile çalışma sayfasını sicile göre ayrı ayrı PDF kaydedebiliyoruz. Şimdi ihtiyaç duyduğum şey ise, yine aynı şekilde JPG formatında kayıt yapabilmek.

Yardımlarınız için çok teşekkür ederim.
 

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 dosyayı bir dene kod ofis 2003 de çalışyor.
 

Ekli dosyalar

Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Alternatif; tek pdf dosyası olarak kayıt için


Kod: 
Sub izinformpdf()
'Asri Akdeniz - asriakdeniz@gmail.com - www.asriakdeniz.com

If MsgBox("T.Data sayfasındaki tüm kişiler için izin formu toplu pdf olarak hazırlanacak, Devam edilsin mi?", vbYesNo) = vbNo Then Exit Sub

Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
   If Left(Sheets(i).Name, 9) = "IZIN FORM" Then Sheets(i).Delete
Next i
Application.DisplayAlerts = True

For i = 2 To Sheets("T.Data").[A65536].End(xlUp).Row
   Sheets("T.Yıllık İzin").Range("BI4:BI12").ClearContents

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

    Sheets("T.Yıllık İzin").Select
    'ActiveSheet.Buttons.Add(497.25, 12.75, 108.75, 39.75).Select
    'ActiveSheet.Buttons.Add(497.25, 64.5, 108.75, 40.5).Select
    Sheets("T.Yıllık İzin").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "IZIN FORM " & i - 1

Next i
  
    Call pdf_olustur
  
    Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
       If Left(Sheets(i).Name, 9) = "IZIN FORM" Then Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
  
    Sheets("T.Yıllık İzin").Select
End Sub

Sub pdf_olustur()
ReDim liste(0 To Sheets.Count)
say = 0
adet = 0
For i = 1 To Sheets.Count
    If Left(Sheets(i).Name, 9) = "IZIN FORM" Then
       adet = adet + 1
    End If
Next i

ReDim liste(1 To adet)
say = 0
For i = 1 To Sheets.Count
    If Left(Sheets(i).Name, 9) = "IZIN FORM" Then
       say = say + 1
       liste(say) = Sheets(i).Name
    End If
Next i
Sheets(liste()).Select
  
yol = ActiveWorkbook.Path & "\IZIN_FORMLARI.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
 

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 kod çok kısa ve birazcık forklı
Bilgi ayarında clipbrd.dll dosyası varsa çalışır.

Kod: 
Sub deneme1()

Dim myClp As Object
Set myClp = CreateObject("clipbrd.clipboard")

If MsgBox("Data sayfasında A sütununda yer alan tüm sicil numaraları için ayrı ayrı form oluşturulacak ve C:\Dosyalar klasörüne kaydedilecek, Devam edilsin mi?", vbYesNo + vbQuestion, " UYARI ") = vbNo Then Exit Sub
sayfa = ActiveSheet.Name
yol = "C:\Dosyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(yol) = False Then
MkDir yol
End If
For r = 2 To Sheets("Data").Cells(Rows.Count, "a").End(3).Row

ThisWorkbook.Sheets(sayfa).Cells(1, "O").Value = ThisWorkbook.Sheets("Data").Cells(r, 1).Value
ThisWorkbook.Sheets(sayfa).Cells(2, "O").Value = ThisWorkbook.Sheets("Data").Cells(r, 2).Value
isim = ThisWorkbook.Sheets(sayfa).Cells(1, "O").Value
myClp.Clear
ActiveSheet.Range("A1:L48").Copy
SavePicture myClp.GetData, yol & "\" & isim & ".jpg"

'ThisWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol & "\" & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next r
Application.CutCopyMode = False
MsgBox "İşlem Tamamlandı.", vbInformation, " Uyarı "


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
Asri' Alıntı:
Alternatif; tek pdf dosyası olarak kayıt için


Kod: 
Sub izinformpdf()
'Asri Akdeniz - asriakdeniz@gmail.com - www.asriakdeniz.com

If MsgBox("T.Data sayfasındaki tüm kişiler için izin formu toplu pdf olarak hazırlanacak, Devam edilsin mi?", vbYesNo) = vbNo Then Exit Sub

Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
   If Left(Sheets(i).Name, 9) = "IZIN FORM" Then Sheets(i).Delete
Next i
Application.DisplayAlerts = True

For i = 2 To Sheets("T.Data").[A65536].End(xlUp).Row
   Sheets("T.Yıllık İzin").Range("BI4:BI12").ClearContents

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

    Sheets("T.Yıllık İzin").Select
    'ActiveSheet.Buttons.Add(497.25, 12.75, 108.75, 39.75).Select
    'ActiveSheet.Buttons.Add(497.25, 64.5, 108.75, 40.5).Select
    Sheets("T.Yıllık İzin").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "IZIN FORM " & i - 1

Next i
 
    Call pdf_olustur
 
    Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
       If Left(Sheets(i).Name, 9) = "IZIN FORM" Then Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
 
    Sheets("T.Yıllık İzin").Select
End Sub

Sub pdf_olustur()
ReDim liste(0 To Sheets.Count)
say = 0
adet = 0
For i = 1 To Sheets.Count
    If Left(Sheets(i).Name, 9) = "IZIN FORM" Then
       adet = adet + 1
    End If
Next i

ReDim liste(1 To adet)
say = 0
For i = 1 To Sheets.Count
    If Left(Sheets(i).Name, 9) = "IZIN FORM" Then
       say = say + 1
       liste(say) = Sheets(i).Name
    End If
Next i
Sheets(liste()).Select
 
yol = ActiveWorkbook.Path & "\IZIN_FORMLARI.pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=yol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
Genişletmek için tıkla ...
Asri Bey, çok teşekkürler.
 
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
Sayın denese 33 nolu mesajdaki kodu denedinizmi çalışıyormu
 
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ı:
Sayın denese 33 nolu mesajdaki kodu denedinizmi çalışıyormu
Genişletmek için tıkla ...
Hocam bu kodu deneyemedim. Kullandığım bilgisayar şirket bilgisayarı olduğu için bazı erişimlerim sınırlı. İlk fırsatta deneyeceğim. Saygılar, selamlar.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst