tirEdsOuL
Altın Üye
- Katılım
- 3 Şubat 2009
- Mesajlar
- 326
- Excel Vers. ve Dili
- Office 2016
- Altın Üyelik Bitiş Tarihi
- 24-08-2026
Merhabalar,
Aşağıdaki kodu Autpen olarak ayarlayacağım ama bu sefer hem excel her açıldığında mail atacak, hemde koşul gerçekleşmezse de boş olarak mail atacak. Bu kodun sadece koşulun gerçekleşmesi ile günde sadece 1 kere çalışmasını sağlayabilir miyiz?
Aşağıdaki kodu Autpen olarak ayarlayacağım ama bu sefer hem excel her açıldığında mail atacak, hemde koşul gerçekleşmezse de boş olarak mail atacak. Bu kodun sadece koşulun gerçekleşmesi ile günde sadece 1 kere çalışmasını sağlayabilir miyiz?
Kod:
Sub mail()
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim xlOutlook As Object
Dim xlMail As Object
Dim WorkSheetName As String
Dim rng As Range
Dim Dtime As Date
WorkSheetName = "Rapor" 'Değiştirilecek
With ThisWorkbook.Worksheets(WorkSheetName)
For Each rng In .Range("A8:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
'İlk satırda K değeri
'İkinci satırda L değeri
'Üçüncü satırda K değeri ile bugün arasında 175 gün var mı diye kontrol
If rng.Offset(0, OffSetNum("K")).Value <> "" And _
rng.Offset(0, OffSetNum("L")) = "" And _
DateDiff("d", rng.Offset(0, OffSetNum("K")).Value, Now) >= 175 Then
metin = metin & "Sipariş No : " & rng.Offset(0, OffSetNum("D")).Value & " " & "Banka : " & rng.Offset(0, OffSetNum("C")).Value & " " & "Kapama Tarihi : " & DateAdd("d", 179, rng.Offset(0, OffSetNum("K")).Value) & "<br>"
aciklama = "Aşağıda bilgileri verilen araçların kapama tarihleri yaklaşmıştır."
baslik = "Yaklaşan araç kapamaları hk."
End If
Next rng
End With
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)
Set fso = CreateObject("Scripting.FileSystemObject")
With xlMail
.To = "xxx@xxx.com.tr"
.CC = "xxx@xxx.com.tr"
.Subject = baslik
.HTMLBody = "<font face=calibri>" & aciklama & "<BR><BR>" & _
metin & "</font>" & "<BR><BR>"
.Save
.Display
'.Send
End With
Set xlMail = Nothing
Set xlOutlook = Nothing
metin = Empty
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function OffSetNum(ByVal ColName As String) As Double 'OffSet değerini bulma
OffSetNum = Range(ColName & "1").Column - 1
End Function