Makro ile filtrelenmiş satırlardaki ilgili kişilere otomatik mail gönderme

[Ellyf]

Merhaba,
Şirkette sözleşmeleri takip ettiğimiz bir excel dosyamız var. Bu dosyada her bir satırda bir sözleşme var ve sütunlarda sözleşmenin konusu, kiminle yapıldığı ve şirkette sözleşme konusunda ilgili kişilerin mail adresleri, sözleşmenin başlangıç ve bitiş tarihi var. Bu dosyadan süresi 90 gün ve daha az sürede dolacak sözleşmeleri filtreleyen bir makro hazırladım. Ayrı bir makro ile de belirli kişilere bu listeyi outlook'ta ek olarak göndermeyi başardım. Ancak istediğim şu; tek bir makro ile bitiş tarihi 90 gün ve daha az olan satırlar filtrelensin ve de her bir sözleşmenin karşısındaki ilgili kişilere mail gönderilsin.

Firma İsmi	Sözleşme Konusu	Başlangıç Tarihi	Bitiş Tarihi	Kalan Gün	İlgili Kişi	Yöneticisi
XYZ	Makine İmalatı	06.05.2022	06.05.2023	30	abc@outlook.com	def@outlook.com

Yukarıdaki gibi bir tablo olduğunu düşünelim, onlarca sözleşme var. Bu makro çalıştığında önce 90 gün ve az süresi kalan sözleşmeleri filtrelesin sonra da her bir sözleşme için To'da ilgili kişi, Cc'de yönetici sütunundaki mail adreslerine Konu: Sözleşme Hatırlatma İçerik: Firma İsmi alanında yazan firmanın Sözleşme Konusu alanında yazan konulu sözleşmesinin bitmesine Kalan gün sütununda yazan gün sayısı kadar süre kalmıştır. şeklinde otomatik mailler gitsin istiyorum.

To: abc@outlook.com
Cc: def@outlook.com

Subject: Sözleşme Hatırlatma

İçerik:
XYZ firması ile yapılmış olan Makine İmalatı konulu sözleşmenin bitmesine 30 gün kalmıştır.

Bana bu konuda yardımcı olabilirseniz çok memnun olurum.
Şimdiden teşekkürler

 

[dgdizayn]

Sub FiltrelenmisSatirlariEpostaIleGonder()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim LastRow As Long
    Dim i As Long
    
    Set sh = ActiveSheet 'Aktif çalışma sayfası olarak ayarla
    LastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row 'Veri tablosundaki son satırı bulun
    
    'Outlook uygulamasını açın
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    'Her bir filtrelenmiş satır için döngü oluşturun
    For i = 2 To LastRow
        If Not sh.Rows(i).Hidden Then 'Eğer satır filtrelenmediyse
            Set OutMail = OutApp.CreateItem(0) 'E-posta nesnesi oluşturun
            
            'E-posta konusunu ve alıcı adresini ayarlayın
            OutMail.Subject = "Konu Başlığı"
            OutMail.To = sh.Cells(i, "B").Value 'Alıcı e-posta adresi (örneğin B sütunu)
            
            'E-posta gövdesini oluşturun (örneğin A ve C sütunlarındaki değerleri kullanarak)
            OutMail.Body = "Merhaba " & sh.Cells(i, "A").Value & "," & vbCrLf & vbCrLf & _
                            "Bu e-posta, şu anda filtrelenmiş bir Excel tablosunda yer alan size ait bilgileri içermektedir:" & vbCrLf & vbCrLf & _
                            "Bilgi 1: " & sh.Cells(i, "C").Value & vbCrLf & _
                            "Bilgi 2: " & sh.Cells(i, "D").Value & vbCrLf & vbCrLf & _
                            "Saygılarımla,"
            
            'E-postayı gönderin
            OutMail.Send
            
            'E-posta nesnesini kaldırın
            Set OutMail = Nothing
        End If
    Next i
    
    'Outlook uygulamasını kapatın
    OutApp.Session.Logoff
    Set OutApp = Nothing
    
End Sub

 

[Ellyf]

Merhaba,
Öncelikle çok teşekkür ederim.
Makroyu denedim, filtrelemiyor ancak satırlarda tanımlı kişilere mail gönderiyor. Bu haliyle de işimi görüyor.
Tekrar teşekkürler

 

[dost]

Merhaba,

Deneyiniz...

Sub FiltrelenmisSatirlariEpostaIleGonder()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim visRng, Rng As Range
    
    Application.ScreenUpdating = False
    
    Set sh = ActiveSheet 'Aktif çalışma sayfası olarak ayarla
    LastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row 'Veri tablosundaki son satırı bulun
    
    sh.UsedRange.Parent.AutoFilterMode = False
    sh.UsedRange.AutoFilter Field:=5, Criteria1:="<=90", Operator:=xlFilterValues
    
    'Outlook uygulamasını açın
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
        
    Set visRng = sh.Range("A2:A" & LastRow)
    
    For Each Rng In visRng.SpecialCells(xlCellTypeVisible)
        Set OutMail = OutApp.CreateItem(0) 'E-posta nesnesi oluşturun
        
        'E-posta konusunu ve alıcı adresini ayarlayın
        OutMail.Subject = "Sözleşme Hatırlatma"
        OutMail.To = Rng.Offset(, 5) 
        OutMail.CC = Rng.Offset(, 6)
        
        'E-posta gövdesini oluşturun (örneğin A ve C sütunlarındaki değerleri kullanarak)
        OutMail.Body = "Sayın ilgili, " & vbCrLf & vbCrLf & _
                        Rng & " firması ile yapılmış olan " & Rng.Offset(, 1) & " konulu sözleşmenin bitmesine " & Rng.Offset(, 4) & " gün kalmıştır." & vbCrLf & vbCrLf & _
                        "Sözleşme başlangıç tarihi: " & Rng.Offset(, 2) & vbCrLf & _
                        "Sözleşme bitiş tarihi:  " & Rng.Offset(, 3) & vbCrLf & vbCrLf & _
                        "Bilgilerinize ... " & vbCrLf & vbCrLf & _
                        "Saygılarımla,"
        
        'E-postayı gönderin
        OutMail.Send
        
        'E-posta nesnesini kaldırın
        Set OutMail = Nothing
    Next
    
    sh.UsedRange.Parent.AutoFilterMode = False
    'Outlook uygulamasını kapatın
    OutApp.Session.Logoff
    Set OutApp = Nothing:  Set visRng = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

 

[Ellyf]

Merhaba,
Çok teşekkür ederim, tam olarak istediğim gibi. Elinize sağlık