Günlük Geç çıkışları kontrol etmek

[kurthan]

arkadaşlar merhaba;

günlük çıkış işlemlerinin 14:00 bitmiş misafirlerinde ayrılmış olması gerekir.
lakin bazen 14:00 dan sonra çıkanlar oluyor.bunu ne kadar geç çıktığını tespit etmek için makro yazmam gerekiyor.
ekte detaylı anlatmaya çalıştım yardımcı olursanız sevinirim.


şimdiden tşk.ler.

 

[kurthan]

konu ile ilgili yardımlarınızı rica ediyorum.

 

[Korhan Ayhan]

Selamlar,

Ham verinizin olduğu sayfanızın ismini DATA olarak değiştirin.
Bir adet yeni sayfa ekleyin. Bu sayfanın adınıda RAPOR olarak değiştirin.

Görsellik bakımından sütun başlıklarınıda rapor sayfasına aktarın. Örnek dosyada uyarlanmış halini görebilirsiniz.

Aşağıdaki kodu boş bir modüle ekleyip çalıştırın.

Uygulama sıkıntı yaşarsanız ekteki örnek dosyayıda inceleyebilirsiniz.

Option Explicit
 
Sub LATE_CHECKOUT_LİSTESİ()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim TARİH1 As Date, TARİH2 As Date, Satır As Long
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("RAPOR")
 
    S2.Select
    Range("A2") = Right(S1.Range("A5"), 10)
    Range("A6:U65536").Clear
    Range("F6:G65536").NumberFormat = "m/d/yyyy"
    Range("H6:H65536").NumberFormat = "[$-F400]h:mm:ss AM/PM"
    Cells.Font.Name = "Tahoma"
    Satır = 6
 
    For X = 12 To S1.Range("A65536").End(3).Row
        If S1.Cells(X, "A") <> "" Then
            TARİH1 = S1.Cells(X, "L")
            TARİH2 = DateSerial(Year(S1.Cells(X, "L")), Month(S1.Cells(X, "L")), Day(S1.Cells(X, "L"))) + TimeSerial(14, 0, 0)
            If TARİH1 > TARİH2 Then
                Cells(Satır, 1) = S1.Cells(X, 1)
                Cells(Satır, 2) = S1.Cells(X, 3)
                Cells(Satır, 3) = S1.Cells(X, 5)
                Cells(Satır, 4) = S1.Cells(X, 6)
                Cells(Satır, 5) = S1.Cells(X, 7)
                Cells(Satır, 6) = S1.Cells(X, 8)
                Cells(Satır, 7) = S1.Cells(X, 12)
                Cells(Satır, 8) = TARİH1 - TARİH2
                Cells(Satır, 9) = S1.Cells(X, 13)
                Cells(Satır, 10) = S1.Cells(X, 14)
                Cells(Satır, 11) = S1.Cells(X, 15)
                Cells(Satır, 12) = S1.Cells(X, 16)
                Cells(Satır, 13) = S1.Cells(X, 17)
                Cells(Satır, 14) = S1.Cells(X, 18)
                Cells(Satır, 15) = S1.Cells(X, 19)
                Cells(Satır, 16) = S1.Cells(X, 20)
                Cells(Satır, 17) = S1.Cells(X, 21)
                Cells(Satır, 18) = S1.Cells(X, 22)
                Cells(Satır, 19) = S1.Cells(X, 24)
                Cells(Satır, 20) = S1.Cells(X, 27)
                Cells(Satır, 21) = S1.Cells(X, 35)
                Satır = Satır + 1
            End If
        End If
    Next
 
    Range("A5").CurrentRegion.Borders.LineStyle = 1
    Cells.EntireColumn.AutoFit
 
    Set S1 = Nothing
    Set S2 = Nothing
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kurthan]

Korhan Hocam teşekkürler çok makbule geçti