Makro günde bir kere çalışsın

tirEdsOuL · 20 Aralık 2017

Merhabalar,

Aşağıdaki kodu Aut

pen 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

Asri · 20 Aralık 2017

Günde bir defa çalışması için aşağıdaki örneği kullanabilirsiniz.
Mail gönderimi tamamlandıktan sonra A1 e günün tarihini yazın.

Program ilk açıldığında a1 deki tarih ile günün tarihini karşılaştırsın. Aynı ise işlem yapmasın. Değil ise işleme devam etsin.

Kod:

Sub gunde_bir_defa()
    eskitarih = CDate(Range("A1").Value)
    If Date <> eskitarih Then
       'yapılacak işlemler
       a = a
    End If
    
  'işlemlerin en sonuna A1 e günün tarihini yazın
    Range("A1").Value = Date
End Sub

Boş mail gitmemesi için mail gönderen kodları koşulun içine ekleyin.

tirEdsOuL · 20 Aralık 2017

Merhaba asri bey, öncelikle ilginiz için teşekkürler.
A1'e bugünün tarihini kendimiz yazacağız doğru anlıyorum değil mi ? Eğer doğru ise, bu pek kullanışlı olmayacaktır, çünkü excel dosyası ağda ortak kullanımdadır ve herkes bu özeni gösteremeyebilir ya da ilk dosyayı ilk açan daha kayıt işlemini yapmadan bir başkası salt okunarak açabilir ve makro yine çalışacaktır.

Asri · 20 Aralık 2017

tirEdsOuL' Alıntı:
Merhaba asri bey, öncelikle ilginiz için teşekkürler.
A1'e bugünün tarihini kendimiz yazacağız doğru anlıyorum değil mi ? Eğer doğru ise, bu pek kullanışlı olmayacaktır, çünkü excel dosyası ağda ortak kullanımdadır ve herkes bu özeni gösteremeyebilir ya da ilk dosyayı ilk açan daha kayıt işlemini yapmadan bir başkası salt okunarak açabilir ve makro yine çalışacaktır.

Kodu incelemediniz sanırım.

En alttaki kod bölümünde sistem otomatik A1 e bugünün tarihini atıyor.
Tabiki dosya salt okunur olmamalı ve kaydedilmiş olmalı.

Sonuç olarak birden fazla kişi kullansa bile biri normal açacak ve kaydecek yada kaydetmeli.

tirEdsOuL · 20 Aralık 2017

Evet kodu incelemeden yorum yapmıştım ve denediğimde de sağlıklı çalıştığını gördüm, kusura bakmayın. Kayıt olayınıda, ilgili kodun sonuna ActiveWorkbook.Save ekleyerek çözdüm, unutmaya mahal vermemek adına.
Tekrar ilginiz için çok çok teşekürler.

tirEdsOuL · 21 Aralık 2017

asri' Alıntı:
Günde bir defa çalışması için aşağıdaki örneği kullanabilirsiniz.
Mail gönderimi tamamlandıktan sonra A1 e günün tarihini yazın.

Program ilk açıldığında a1 deki tarih ile günün tarihini karşılaştırsın. Aynı ise işlem yapmasın. Değil ise işleme devam etsin.

Kod:

Sub gunde_bir_defa() eskitarih = CDate(Range("A1").Value) If Date <> eskitarih Then [COLOR="Red"]'yapılacak işlemler[/COLOR] a = a End If 'işlemlerin en sonuna A1 e günün tarihini yazın Range("A1").Value = Date End Sub

Boş mail gitmemesi için mail gönderen kodları koşulun içine ekleyin.

Merhaba,

Herşey sağlıklı çalışıyor ama, koşullar oluşmadığı zaman boş mail gönderme durumunu engelleyemedim. Yapılacak işlemler dediğiniz alana aşağıdaki mail gönderme kodunu ekledim.

Kod:

Sub mail_gonder()
    eskitarih = CDate(Range("A1").Value)
    If Date <> eskitarih Then
    
    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) >= 172 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
    
    a = a
    End If
    
  'işlemlerin en sonuna A1 e günün tarihini yazın
    Range("A1").Value = Date
    ActiveWorkbook.Save
End Sub

Asri · 21 Aralık 2017

Öcelikle test etmedim. Ancak sorun olmaması gerekiyor.
Kontrol ediniz.

Önemli:
Z kolonunu mail gönderildi gönderilmedi olarak güncelleyecek.
Bu neden ile her çalıştığında Z kolonunu silecektir.

Bir tane bir mail gönderildi ise A1 mail gönderildi yazacaktır.

Kod:

Dim aciklama, metin As String
Dim WorkSheetName As String
Dim rng As Range
Dim Dtime As Date
Dim xlOutlook   As Object
Dim xlMail      As Object
Dim gonderilmedi As Boolean     
     
Sub menu()
    eskitarih = CDate(Range("A1").Value)
    If Date <> eskitarih Then
       Call mail_hazirlik
    End If
End Sub

Sub mail_hazirlik()
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    'Mail gönderildi gönderilmedi kontrolü sıfırla
    Range("Z:Z").Clear
    
    WorkSheetName = "Rapor" 'Değiştirilecek
    With ThisWorkbook.Worksheets(WorkSheetName)
   [COLOR=Red] kosulvar=false[/COLOR]
    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."   
           kosulvar=true        
        End If
    Next rng
    End With

  [COLOR=red] if kosulvar then
           Call mail_gonder
           
           'Mail gönderildi gönderilmedi kontrolü
           If gonderilmedi Then
              
           Else
              Range("A1").Value = Date
           End If

  end if[/COLOR]
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Sub mail_gonder()
 Set xlOutlook = CreateObject("Outlook.Application")
 Set xlMail = xlOutlook.CreateItem(0)
 Set fso = CreateObject("Scripting.FileSystemObject")
 
 gonderilmedi = False
 On Error GoTo hata
 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

 GoTo son
hata:
  'MsgBox ("Mail gönderilemedi")
  gonderilmedi = True
son:
 Set xlMail = Nothing
 Set xlOutlook = Nothing
 metin = Empty
End Sub

Function OffSetNum(ByVal ColName As String) As Double 'OffSet değerini bulma
    OffSetNum = Range(ColName & "1").Column - 1
End Function

tirEdsOuL · 21 Aralık 2017

Merhaba;
Öncelikle "menu" makrosunda çağrılan "mail_gonder" makrosunu "mail_hazirlik" makro ile değiştirdim çünkü; bu sefer hep boş mail ekranını açıyordu. Sonrasında ise "mail_hazirlik" makrosunun içinde çağrılan "mail_gonder" makrosunu End With'in altına aldım çünkü koşulun gerçekleşmesi sonucu her satır için ayrı ayrı mail atıyordu.
Ama koşulun hiçbir şekilde gerçekleşmemesi sonucu yine de boş mail ekranını açıyor.
Dip not; Bu kopmlike makroları ben Aut

pen olarak kullandığımda bir makronun içine "Call menu" olarak çağırarak çalıtırıyorum.

Asri · 21 Aralık 2017

tirEdsOuL' Alıntı:
Merhaba;
Öncelikle "menu" makrosunda çağrılan "mail_gonder" makrosunu "mail_hazirlik" makro ile değiştirdim çünkü; bu sefer hep boş mail ekranını açıyordu. Sonrasında ise "mail_hazirlik" makrosunun içinde çağrılan "mail_gonder" makrosunu End With'in altına aldım çünkü koşulun gerçekleşmesi sonucu her satır için ayrı ayrı mail atıyordu.
Ama koşulun hiçbir şekilde gerçekleşmemesi sonucu yine de boş mail ekranını açıyor.
Dip not; Bu kopmlike makroları ben Autpen olarak kullandığımda bir makronun içine "Call menu" olarak çağırarak çalıtırıyorum.

Kodu güncelledim.

Koşulun gerçekleşip gerçekleşmediğini kontrol etmeden mail gönderirseniz. Boş mail gider.

Bu şekilde dener misiniz?

tirEdsOuL · 21 Aralık 2017

Şuanda sorunsuz çalışıyor asri bey, ilginiz için çok teşekkürler.