DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Teşekkürler iyi çalışmalarHalit Hocam, emekleriniz çok büyük ve değerli. Tekrar çok teşekkür ediyorum.
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
Çok teşekkür ederim hocam. Allah razı olsun.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
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
Tekrar teşekkür ederim hocam, çok sağ olun.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
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
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
Halit Hocam office365 kullanıyorum ve kod sorunsuz çalıştı. Tekrar çok teşekkür ediyorum. Allah razı olsun.Bu dosyayı bir dene kod ofis 2003 de çalışyor.
Teşekkürler iyi çalışmalarHalit Hocam office365 kullanıyorum ve kod sorunsuz çalıştı. Tekrar çok teşekkür ediyorum. Allah razı olsun.
Asri Bey, çok teşekkürler.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
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.Sayın denese 33 nolu mesajdaki kodu denedinizmi çalışıyormu