- Katılım
- 7 Mart 2024
- Mesajlar
- 35
- Excel Vers. ve Dili
- 2020
- Altın Üyelik Bitiş Tarihi
- 20-03-2025
Sub Zamanı_Geldi()
Application.OnTime TimeValue("14:22:30"), ThisWorkbook.Name & "!Sayfa1.Düğme1_Tıkla"
End Sub
Sub Düğme1_Tıkla()
Dim ws As Worksheet
Dim rngTarih As Range, cellTarih As Range
Dim rngMail As Range
Dim mailKonu As String, mailIcerik As String
Dim outlookApp As Object
Dim outlookMail As Object
Dim sonSatir As Long
Set ws = ThisWorkbook.Sheets("Sayfa1")
sonSatir = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
Set rngTarih = ws.Range("I7:I" & sonSatir)
mailKonu = "Tarihi Geçen Değerler"
mailIcerik = "Bugün() değerinden küçük olan değerler:" & vbCrLf
For Each cellTarih In rngTarih
If cellTarih.Value < Date Then
If rngMail Is Nothing Then
Set rngMail = ws.Cells(cellTarih.Row, "H")
Else
Set rngMail = Union(rngMail, ws.Cells(cellTarih.Row, "H"))
End If
End If
Next cellTarih
If rngMail Is Nothing Then
MsgBox "Tarihi geçen hücre bulunamadı!", vbExclamation
Exit Sub
End If
For Each cell In rngMail
mailIcerik = mailIcerik & cell.Value & vbCrLf
Next cell
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.To = "o.ankara19@hotmail.com"
.Subject = mailKonu
.Body = mailIcerik
.Send
End With
Set outlookMail = Nothing
Set outlookApp = Nothing
End Sub
Her yolu denedim ama bir türlü çalışmıyor hata mesajıda vermiyor msgbox falan ekledim herhangi bir tepki vermiyor yardım edecek üstadım varmı?
Application.OnTime TimeValue("14:22:30"), ThisWorkbook.Name & "!Sayfa1.Düğme1_Tıkla"
End Sub
Sub Düğme1_Tıkla()
Dim ws As Worksheet
Dim rngTarih As Range, cellTarih As Range
Dim rngMail As Range
Dim mailKonu As String, mailIcerik As String
Dim outlookApp As Object
Dim outlookMail As Object
Dim sonSatir As Long
Set ws = ThisWorkbook.Sheets("Sayfa1")
sonSatir = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
Set rngTarih = ws.Range("I7:I" & sonSatir)
mailKonu = "Tarihi Geçen Değerler"
mailIcerik = "Bugün() değerinden küçük olan değerler:" & vbCrLf
For Each cellTarih In rngTarih
If cellTarih.Value < Date Then
If rngMail Is Nothing Then
Set rngMail = ws.Cells(cellTarih.Row, "H")
Else
Set rngMail = Union(rngMail, ws.Cells(cellTarih.Row, "H"))
End If
End If
Next cellTarih
If rngMail Is Nothing Then
MsgBox "Tarihi geçen hücre bulunamadı!", vbExclamation
Exit Sub
End If
For Each cell In rngMail
mailIcerik = mailIcerik & cell.Value & vbCrLf
Next cell
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.To = "o.ankara19@hotmail.com"
.Subject = mailKonu
.Body = mailIcerik
.Send
End With
Set outlookMail = Nothing
Set outlookApp = Nothing
End Sub
Her yolu denedim ama bir türlü çalışmıyor hata mesajıda vermiyor msgbox falan ekledim herhangi bir tepki vermiyor yardım edecek üstadım varmı?