• DİKKAT

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

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

  • Konbuyu başlatan Konbuyu başlatan denese
  • Başlangıç tarihi Başlangıç tarihi
D

denese

Katılım
17 Mart 2011
Mesajlar
441
Excel Vers. ve Dili
Office 2019
Merhaba,

Forumda araştırdım, makro bilgim yok denecek kadar az olsa da toplu yazdırma konusunda sonuca ulaştım. Ancak; data sayfasındaki isimlerin her biri için, şifreli xls formatında dosya oluşturacak ve oluşturulan bu dosyaları belirtilen mail adresine gönderecek bir makro konusunda işin içinden çıkamadım.

Örnek dosya ektedir.
http://s6.dosya.tc/server8/wwzrgk/Ucret_Bilgilendirme.rar.html

Yardım ve yönlendirmeleriniz için şimdiden teşekkür ederim.
 

Ekli dosyalar

Son düzenleme:
denese' Alıntı:
Merhaba,

Forumda araştırdım, makro bilgim yok denecek kadar az olsa da toplu yazdırma konusunda sonuca ulaştım. Ancak; data sayfasındaki isimlerin her biri için, şifreli xls formatında dosya oluşturacak ve oluşturulan bu dosyaları belirtilen mail adresine gönderecek bir makro konusunda işin içinden çıkamadım.

Örnek dosya ektedir.
http://s6.dosya.tc/server8/wwzrgk/Ucret_Bilgilendirme.rar.html

Yardım ve yönlendirmeleriniz için şimdiden teşekkür ederim.
Genişletmek için tıkla ...

Merhaba,

Mail adresi girilen satırları ilgili adrese mail göndermeniz için gerekli dosya ekteki gibidir. Tek dikkat etmeniz gereken Mail Gönder butonuna tıkladığınız zaman sayfada herhangi bir filtreleme olmaması gerekiyor. Bu durumda mail boş gider. Diğer konuda bahsetmiş olduğunuz gibi dosya oluşturup bunu iletmek konusunda malesef benim boyumu aşan bir durum söz konusu :)
 

Ekli dosyalar

Merhaba
Makroları deneyin
(" 'Send") Göndermek ve ('.Password = şifre) şifre için başlarındaki kesme işaretlerini kaldırırsınız


Kod: 
Sub Farkli_kaydet()
 Dim s1, s2 As Worksheet
 Set s = ThisWorkbook
Set s1 = s.Sheets("Ücret Bilgilendirme")
Set s2 = s.Sheets("Data")
For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
şifre = Trim(s2.Cells(a, "G"))
s1.[O1] = Trim(s2.Cells(a, "B"))
s1.[O2] = Trim(s2.Cells(a, "D").Text)
ad = Trim(s2.Cells(a, "F"))
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("Ücret Bilgilendirme")
.Range("A1:L37").Value = s1.Range("A1:L37").Value
.Columns("M:X").Delete Shift:=xlToLeft
End With
[COLOR="Red"]'.Password = şifre[/COLOR]
 .SaveAs Filename:=kayıt
   .Close
End With
Next
End Sub
Kod: 
Sub Mail_gönder()
 Dim objOutlook As Object
 Dim s As Workbook, a As Long
 Dim s2, s3 As Worksheet
 Set s = ThisWorkbook
Set s2 = s.Sheets("Data")
Set s3 = s.Sheets("Mail İçeriği")
Set n = CreateObject("scripting.filesystemobject")
Dim objMail As Object
For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
                Set objOutlook = CreateObject("Outlook.Application")
                Set objMail = objOutlook.CreateItem(0)
                With objMail
                    .To = s2.Cells(a, "I").Value
                    .CC = ""
                    .Subject = s2.Cells(a, "J").Value
                   .HtmlBody = "<BODY style=font-size:11pt;font-family:Calibri><B>" & _
                    s3.Range("A1") & "<br>" & "</B><br>" & _
                    s3.Range("A3") & "<br>" & "<br>" & _
                    s3.Range("A5") & "<br>" & "<B><br>" & _
                    s3.Range("A7") & "<br>" & "</B><br>" & _
                    s3.Range("A9") & "<br>" & "<br>" & _
                    s3.Range("A11") & "<br>" & "<BR>"
If n.FileExists(s2.Cells(a, "H").Value) = True Then
                 .Attachments.Add s2.Cells(a, "H").Value
                 Else
                  MsgBox s2.Cells(a, "H").Value & " Dosyası bulunamadı"
                  End If
                    .Save
                   .send
                End With
                Next
          End Sub
http://s3.dosya.tc/server11/qsens3/Ucret_Bilgilendirme2.zip.html
 
Son düzenleme:
Sayın PLİNT,

Yapmak istediğim tam olarak buydu, çok teşekkür ederim.

Emeğinize, yüreğinize sağlık.

İyi çalışmalar
 
Merhaba Sayın PLİNT,

Tümünü Farklı Kaydet butonuna tıkladığımda, bugün bir sorunla karşılaştım. Farklı kaydederek oluşturulan dosyalar .xls formatında, bense excel 2016 kullanıyorum, dolayısınla bu sebepten midir bilmiyorum uyumluluk denetleyicisi devreye giriyor ve devam dediğimde ise farklı kaydedilen her .xls dosyası için devam demek durumunda kalıyorum.

Farklı kaydedilen dosya türünü kod içerisinde .xlsx yapmayı denedim ancak hata verdi. Bu durum nasıl aşılabilir?

http://s6.dosya.tc/server8/s3o8uc/Ucret_Bilgilendirme.rar.html

http://s3.dosya.tc/server11/pyqx3b/Uyumluluk_Denetleyicisi.png.html
 

Ekli dosyalar

Son düzenleme:
denese' Alıntı:
Merhaba Sayın PLİNT,

Tümünü Farklı Kaydet butonuna tıkladığımda, bugün bir sorunla karşılaştım. Farklı kaydederek oluşturulan dosyalar .xls formatında, bense excel 2016 kullanıyorum, dolayısınla bu sebepten midir bilmiyorum uyumluluk denetleyicisi devreye giriyor ve devam dediğimde ise farklı kaydedilen her .xls dosyası için devam demek durumunda kalıyorum.

Farklı kaydedilen dosya türünü kod içerisinde .xlsx yapmayı denedim ancak hata verdi. Bu durum nasıl aşılabilir?
Genişletmek için tıkla ...
Merhaba
Konu başlığınızda "xls" görünce mail göndereceğiniz kişilerden dolayı bu formatı istediğinizi düşünmüştüm
Yukarıda mesajdaki değişen "Farklı Kaydet" makrosunu deneyin.
 
Sayın PLİNT,

Konu başlığında gerekli düzeltmeyi yaptım, desteğiniz için tekrar teşekkür ederim.

İyi çalışmalar
 
Merhaba Sayın PLİNT,

Mail gönder makrosunu bugün test etme imkanım oldu. Ufak bir sorun var. "Mail İçeriği" sayfasında A1 hücresinde bulunan "Sayın Personel-1" yazısı, maili gönderdiğimizde çıkmıyor. Bir de yazı tipini tüm mail içeriği için Calibri, boyutunu ise 11 yapabilir miyiz. Bir de A1 ve A7 deki içeriği kalınlaştırarak vurgulamak istiyorum. Bu konuda da yardımcı olabilir misiniz.

İyi çalışmalar dilerim.

http://s9.dosya.tc/server2/obg566/Mail_Ekran_Goruntusu.png.html
 

Ekli dosyalar

  • Mail Ekran Görüntüsü.jpg
    Mail Ekran Görüntüsü.jpg
    13.3 KB · Görüntüleme: 4
Merhaba
Yukarıdaki kodlarda (Mail_gönder) isteğinize düzeltme yapmaya çalıştım bir deneyelim.
 
Merhaba,

Mail gönder dediğimizde; mail, taslak olarak ekteki şekilde oluştu ve oluşturduğumuz dosya taslağa eklenmedi ve mail gönderilmedi. Mailin konusunda gönderenin e-mail adresi yer alıyor. Bir de mailde tüm metin kalın olmuş.

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

http://s3.dosya.tc/server11/ibg6sq/ekran_goruntusu.png.html
 

Ekli dosyalar

  • ekran görüntüsü.jpg
    ekran görüntüsü.jpg
    18.4 KB · Görüntüleme: 3
Merhaba
Haklısınız denemeden göndermemizin sonucu öyle olmuş şöyle değişin
Kod: 
[SIZE="2"]Sub Mail_gönder()
 Dim objOutlook As Object
 Dim s As Workbook, a As Long
 Dim s2, s3 As Worksheet
 Set s = ThisWorkbook
Set s2 = s.Sheets("Data")
Set s3 = s.Sheets("Mail İçeriği")
Set n = CreateObject("scripting.filesystemobject")
Dim objMail As Object
For a = 2 To s2.Cells(Rows.Count, "F").End(3).Row
[COLOR="Red"]s3.Cells(1, "A") = [COLOR="Blue"]"Sayın " &[/COLOR] s2.Cells(a, "B").Value[/COLOR]
                Set objOutlook = CreateObject("Outlook.Application")
                Set objMail = objOutlook.CreateItem(0)
                With objMail
                    .To = s2.Cells(a, "I").Value
                    .CC = ""
                    .Subject = s2.Cells(a, "J").Value
                   .HtmlBody = "<BODY style=font-size:11pt;font-family:Calibri><B>" & _
                    s3.Range("A1") & "<br>" & "</B><br>" & _
                    s3.Range("A3") & "<br>" & "<br>" & _
                    s3.Range("A5") & "<br>" & "<B><br>" & _
                    s3.Range("A7") & "<br>" & "</B><br>" & _
                    s3.Range("A9") & "<br>" & "<br>" & _
                    s3.Range("A11") & "<br>" & "<BR>"
If n.FileExists(s2.Cells(a, "H").Value) = True Then
                 .Attachments.Add s2.Cells(a, "H").Value
                 Else
                  MsgBox s2.Cells(a, "H").Value & " Dosyası bulunamadı"
                  End If
                    .Save
                   .send
                End With
                Next
[COLOR="Red"]MsgBox "Mail gönderme işlemi tamamlandı"[/COLOR]
          End Sub
 [/SIZE]
 
Son düzenleme:
denese' Alıntı:
Merhaba,

Kod'u sanırım güncellediniz. Bu kodu uyguladığımda ise; maili gönderilmeye hazır olarak ekrana getirdi, ama göndermedi.
Genişletmek için tıkla ...
"send" başındaki kesmeyi kaldıracaktınız,
(".display") görüntülemeyi kaldıralım.
Yukarıda son mesajımdaki kodları deneyin.
İnternet hızına göre ekrana(hemen düşmeyecektir)
 
Sayın PLİNT, desteğiniz için tekrar çok teşekkür ediyorum.

İyi çalışmalar dilerim.
 
Merhaba,

Kusura bakmayın lütfen, farklı şekillerde deneme yaparak sonuçları görmeye çalışıyorum. Bir şey daha oluştu;

Data sayfasında birden fazla kişi listelediğimde, mail içeriği sayfasında A1 hücresinde yer alan "Sayın Personel-01" ifadesi de her kişi için değişmesi gerek, ancak herkese aynı ifadeyle mail gönderiyor.

Bir de; tüm mailler gönderildikten sonra "Mail gönderme işlemi tamamlandı" şeklinde bilgilendirme oluşturabilir miyiz.
 
Yukarıdaki kodlarda kırmızı bölümleri kodlarınıza ekleyin.
Gönderilen eklerde bir sorun yok değilmi?
 
Kodları ekledim, sorun çözüldü, sadece ifadenin önünde "Sayın" yazmıyor. Gönderilen ekler sorunsuz.
 
Merhaba
Yukarıda değişen kodlardaki mavi bölüm gibi, "Sayın" ifadesini kodlara ekleyebilirsiniz

Kod: 
s3.Cells(1, "A") = [COLOR="blue"]"Sayın " & [/COLOR]s2.Cells(a, "B").Value
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst