Şablon ile ayrı ayrı .xlsx dosya oluştur, şifrele, mail gönder

[denese]

Ne kadar teşekkür etsem az. Hakkınızı helal edin.

İyi çalışmalar

 

[denese]

Merhaba,

Bu dosyada yapmak istediğim bazı ilaveler var. Ekli dosyada bunları belirttim. Yardımcı olabilirseniz çok minnettar kalırım.

Dosyaya buradan da ulaşabilirsiniz

İyi çalışmalar

 

[denese]

Merhaba Arkadaşlar,

Konuyla ilgili desteğinizi rica ediyorum.

 

[denese]

Sub Farkli_kaydet()
 Dim s1, s2 As Worksheet
 Set s = ThisWorkbook
Set s1 = s.Sheets("Belge")
Set s2 = s.Sheets("Data")
For a = 2 To s2.Cells(Rows.Count, "E").End(3).Row
şifre = Trim(s2.Cells(a, "F"))
s1.[O1] = Trim(s2.Cells(a, "B"))
s1.[O2] = Trim(s2.Cells(a, "C").Text)
ad = Trim(s2.Cells(a, "E"))
Set ds = CreateObject("scripting.filesystemobject")
yol = "C:\"
If ds.FolderExists(yol & "Data") = False Then ds.CreateFolder yol & "Data"
If ds.FolderExists(yol & "Data\" & "Ücret Bilgilendirme") = False Then ds.CreateFolder yol & "Data\" & "Ücret Bilgilendirme"
ChDir "C:\Data\Ücret Bilgilendirme"
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item("C:\Data\Ücret Bilgilendirme\") & _
ad & ".xlsx": s1.Copy
 With Application.ActiveWorkbook
With .Sheets("Belge")
.Range("A1:L48").Value = s1.Range("A1:L48").Value
.Columns("M:X").Delete Shift:=xlToLeft
End With
 .Password = şifre
 .SaveAs Filename:=kayıt
   .Close
End With
Next
End Sub

Yukarıdaki kodda, dosya kayıt yeri C:\Data\Ücret Bilgilendirme olarak sabit durumda. Bu kayıt yerini, D sütununda kişi bazlı belirttiğim kayıt yerine göre değişken yapmak istiyorum.

Oluşturulacak dosya türü değişken olabilir mi? Mesela G sütununda yer alacak olan dosya uzantılarına göre kayıt yapacak, excel uzantılı ise yine şifreli, değil ise şifresiz kaydedecek.

Ek dosya 22 numaralı mesajda yer alıyor, yardımlarınızı rica ediyorum.

 

[PLİNT]

Yukarıdaki kodda, dosya kayıt yeri C:\Data\Ücret Bilgilendirme olarak sabit durumda. Bu kayıt yerini, D sütununda kişi bazlı belirttiğim kayıt yerine göre değişken yapmak istiyorum.

Merhaba
Ek dosyayı deneyin,
"değişken" olarak istediğiniz dosyadaki gibi mi?
http://www.dosya.tc/server8/kwxwle/siye_Ozel_Dosya_Olustur__Farkli_Kaydett_2.zip.html
"Modül2" kod sayfasına:

[SIZE="2"]Dim kytyol As String [/SIZE]

[SIZE="2"]Sub Farkli_kaydet()
 Dim s1, s2 As Worksheet
 Set s = ThisWorkbook
Set s1 = s.Sheets("Belge")
Set s2 = s.Sheets("Data")
For a = 2 To s2.Cells(Rows.Count, "E").End(3).Row
şifre = Trim(s2.Cells(a, "F"))
s1.[O1] = Trim(s2.Cells(a, "B"))
s1.[O2] = Trim(s2.Cells(a, "C").Text)
ad = Trim(s2.Cells(a, "E"))
klas = Trim(s2.Cells(a, "B"))
Set ds = CreateObject("scripting.filesystemobject")
yol = "D:\"
If ds.FolderExists(yol & "Data") = False Then ds.CreateFolder yol & "Data"
If ds.FolderExists(yol & "Data\" & "Ücret Bilgilendirme") = False Then ds.CreateFolder yol & "Data\" & "Ücret Bilgilendirme"
If ds.FolderExists(yol & "Data\Ücret Bilgilendirme\" & klas) = False Then ds.CreateFolder yol & "Data\Ücret Bilgilendirme\" & klas
kytyol = "D:\Data\Ücret Bilgilendirme\" & klas & "\" & ad
If Trim(s2.Cells(a, "G").Text) = "pdf" Or Trim(s2.Cells(a, "G").Text) = "docx" Then
If Trim(s2.Cells(a, "G").Text) = "pdf" Then pdf_kaydet: GoTo 55
If Trim(s2.Cells(a, "G").Text) = "docx" Then doc_kaydet: GoTo 55
End If
ChDir "D:\Data\Ücret Bilgilendirme\" & klas
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item("D:\Data\Ücret Bilgilendirme\" & klas & "\") & _
ad & ".xlsx": s1.Copy
 With Application.ActiveWorkbook
 Application.DisplayAlerts = False
With .Sheets("Belge")
.Range("A1:L48").Value = s1.Range("A1:L48").Value
.Columns("M:X").Delete Shift:=xlToLeft
End With
 .Password = şifre
 .SaveAs Filename:="D:\Data\Ücret Bilgilendirme\" & klas & "\" & kayıt
   .Close
End With
 Application.DisplayAlerts = True
55:
Next

If ds.FolderExists("D:\Data\Ücret Bilgilendirme\" & klas) = True Then
aç = Shell("C:\WINDOWS\Explorer.exe D:\Data\" & "Ücret Bilgilendirme", vbNormalFocus)
 End If

End Sub [/SIZE]

[SIZE="2"]Sub pdf_kaydet()
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
kytyol, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'true
End Sub [/SIZE]

[SIZE="2"]Sub doc_kaydet()
Set s = CreateObject("Word.Application")
Set y = s.Documents.Add
    s.Visible = False
Range("B1:L" & Cells(Rows.Count, "B").End(3).Row).Copy
With y.Range
  .Paste
  Application.CutCopyMode = False
End With
y.SaveAs Filename:=kytyol & ".docx"
 y.Close True
 s.Quit
End Sub
[/SIZE]

 

[denese]

Merhaba Sayın PLİNT,

Dosya türüne göre kayıt işlemi tam istediğim gibi, harika olmuş, elinize sağlık.

Ancak kayıt şekli konusununda yeterli açıklama yapmamışım kusura bakmayın.

Mevcut kodlar "D:\Data\Ücret Bilgilendirme\" klasörü içerisine "Adı Soyadı" sütunundaki isme klasör oluşturuyor, içine "Oluşturulacak Dosya Adı" sütunundaki veri adıyla kaydediyor.

Benim istediğim ise; sadece "Oluşturulacak Dosya Adı" sütunundaki isme göre belge oluşturup (klasör değil, ya da klasör içerisinde değil), "Dosya Kayıt Yeri" sütunundaki adrese (bu adresler her kişi için farklı olabilir) oluşturulacak belge türü .xlsx ise şifreli, değil ise şifresiz kaydetmek.

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

 

[PLİNT]

Merhaba Sayın PLİNT,
Benim istediğim ise; sadece "Oluşturulacak Dosya Adı" sütunundaki isme göre belge oluşturup (klasör değil, ya da klasör içerisinde değil), "Dosya Kayıt Yeri" sütunundaki adrese (bu adresler her kişi için farklı olabilir) oluşturulacak belge türü .xlsx ise şifreli, değil ise şifresiz kaydetmek.

Merhaba
http://dosya.pro/download.php?file=46481d09945ee8de4ef15995b03278e3
Yukarıdaki (sadece) "Farklı_Kaydet" makrosunu aşağıdaki ile değiştirip deneyin.

[SIZE="2"]Sub Farkli_kaydet()
Dim s1, s2 As Worksheet: Dim s As Workbook
Dim yol, şifre, ad, deg, kayıt As String
Dim a, j As Long
Set s = ThisWorkbook
Set s1 = s.Sheets("Belge")
Set s2 = s.Sheets("Data")
For a = 2 To s2.Cells(Rows.Count, "E").End(3).Row
yol = Empty
şifre = Trim(s2.Cells(a, "F"))
s1.[O1] = Trim(s2.Cells(a, "B"))
s1.[O2] = Trim(s2.Cells(a, "C").Text)
ad = Trim(s2.Cells(a, "E"))
Set ds = CreateObject("scripting.filesystemobject")
deg = Trim(s2.Cells(a, "D").Text)
yol = Split(deg, "\")(0) & "\"
For j = 1 To UBound(Split(deg, "\"))
If ds.FolderExists(yol & Split(deg, "\")(j)) = False Then ds.CreateFolder yol & Split(deg, "\")(j)
yol = yol & Split(deg, "\")(j) & "\"
Next
kytyol = yol & ad
If Trim(s2.Cells(a, "G").Text) = "pdf" Or Trim(s2.Cells(a, "G").Text) = "docx" Then
If Trim(s2.Cells(a, "G").Text) = "pdf" Then pdf_kaydet: GoTo 55
If Trim(s2.Cells(a, "G").Text) = "docx" Then doc_kaydet: GoTo 55
End If
ChDir yol
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(yol) & ad & ".xlsx": s1.Copy
 With Application.ActiveWorkbook
 Application.DisplayAlerts = False
With .Sheets("Belge")
.Range("A1:L48").Value = s1.Range("A1:L48").Value
.Columns("M:X").Delete Shift:=xlToLeft
End With
 .Password = şifre
 .SaveAs Filename:=yol & kayıt
   .Close
End With
 Application.DisplayAlerts = True
55:
Next

End Sub [/SIZE]

 

[denese]

Harika oldu. Yardımlarınız için çok teşekkür ederim Sayın PLİNT.

Saygılar, selamlar..