Olmayan tarihleri bulmak

[bmutlu966]

01.Ocak.2011 tarihinden sonra hergün dolan bir data tablom var. A kolonunda da tarihler var. Zaman zaman bazı tarihli data girişleri unutulabiliyor. Unutulan bu tarihleri makro yardımıyla bulup başka bir sayfaya yazdırmam gerekiyor. Ekte basit bir örnek hazırladım.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Tarihlerin sıralı olmadığı durum dikkate alınmıştır.

Sub Eksik_Tarihleri_Bul()
    Dim i   As Long, _
        j   As Long, _
        t1  As Date, _
        t2  As Date, _
        c   As Range, _
        se  As Worksheet
    
    Set se = Sheets("Eksik tarihleri getir")
    se.Range("A:A").ClearContents
        
    t1 = Application.WorksheetFunction.Min(Range("A:A"))
    t2 = Application.WorksheetFunction.Max(Range("A:A"))
    
    j = 0
    
    For t1 = t1 To t2
       [B][COLOR=red] If Not Weekday(t1, vbMonday) = 7 Then
[/COLOR][/B]            Set c = Range("A:A").Find(t1, LookIn:=xlFormulas)
            If c Is Nothing Then
                j = j + 1
                se.Cells(j, "A") = t1
             End If
       [B][COLOR=red] End If
[/COLOR][/B]    Next t1
    
    MsgBox j & " Adet Eksik Tarih Buldum....."
    
End Sub

 

[Korhan Ayhan]

Merhaba,

Alternatif olarak döngü yöntemiyle hazırladığım aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub EKSİK_TARİHLER()
    Dim S1 As Worksheet, S2 As Worksheet, X As Date
    Dim İLK_TARİH As Date, SON_TARİH As Date, Satır As Long
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("Tarih")
    Set S2 = Sheets("Eksik tarihleri getir")
 
    S2.Columns(1).ClearContents
 
    İLK_TARİH = WorksheetFunction.Min(S1.Range("A:A"))
    SON_TARİH = Date
 
    For X = İLK_TARİH To SON_TARİH
        If WorksheetFunction.CountIf(S1.Range("A:A"), X) = 0 Then
            If Weekday(X, vbMonday) <> 7 Then
                Satır = Satır + 1
                S2.Cells(Satır, 1) = X
            End If
        End If
    Next
 
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[usubaykan]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Tarihlerin sıralı olmadığı durum dikkate alınmıştır.

 Option Explicit
 
Sub Eksik_Tarihleri_Bul()
    Dim i   As Long, _
        j   As Long, _
        t1  As Date, _
        t2  As Date, _
        c   As Range, _
        se  As Worksheet
    
    Set se = Sheets("Eksik tarihleri getir")
    se.Range("A:A").ClearContents
    
    j = Cells(Rows.Count, "A").End(3).Row
    
    t1 = Range("A1")
    t2 = Cells(j, "a")
    
    j = 0
    
    For t1 = t1 To t2
        Set c = Range("A:A").Find(t1, LookIn:=xlFormulas)
        If c Is Nothing [COLOR=red]And Format(t1, "dddd") <> "Pazar"[/COLOR] Then
            j = j + 1
            se.Cells(j, "A") = t1
        End If
    Next t1
    
    MsgBox j & " Adet Eksik Tarih Buldum....."
    
End Sub

Kırmızı ile yazılı yeri eklerseniz pazar günlerini eksikte olsa dikkate almayacaktır. Ellerinize sağlık Necdet Bey

 

[Necdet]

Kırmızı ile yazılı yeri eklerseniz pazar günlerini eksikte olsa dikkate almayacaktır. Ellerinize sağlık Necdet Bey

Veriler arasında Pazar günü de olduğu için dikkate almadım. Ama açıklamada da varmış onu görmedim.
Kodlar düzeltildi ve benim kırmızılarım daha bir farklı oldu

 

[bmutlu966]

Sayın hocalarım, ilginiz için çok teşekkürler.

Ancak her 2 koddaki son tarih'in bugünü işaret etmesi gerekiyor. Yani =today() formülü.

t2 = Application.WorksheetFunction.Max(Range("A:A"))

SON_TARİH = WorksheetFunction.Max(S1.Range("A:A"))

 

[Korhan Ayhan]

Merhaba,

#3 nolu mesajımda gerekli düzenlemeyi yaptım. Denermisiniz.

 

[bmutlu966]

Korhan hocam çok teşekkürler. Emeğinize sağlık.