Listedeki günün ilk saati ve son saatini alma

[bthn35]

Merhabalar,
Şirkette kullandığımız giriş-çıkış sistemini saat hesaplamak için kullanıyoruz ancak bazen personel gün içinde birden fazla giriş-çıkış yaptığında excel'de hesaplamak zorlaşıyor ve elle düzeltmek zorunda kalıyoruz. Yapmaya çalışıp beceremediğim şey;
1) Listedeki her güne ait ilk giriş saatini ve son çıkış saatini farklı bir alanda alt alta kopyalama,
2) Listedeki her güne ait giriş yada çıkış saati yoksa kırmızı ile işaretlenmesi,

http://s2.dosya.tc/server8/kbxctn/excel_sorun.xlsx.html

 

[veyselemre]

Sub raporla()
    strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & _
             "';Extended Properties=""Excel 12.0;HDR=YES"";"

    Set RS = CreateObject("Adodb.RecordSet")

    Sheets("RAPOR").Cells.ClearContents

    STRSQL = "SELECT personel, cdate(Format(zaman,'Short Date')) AS tarih, " & _
             "First(IIf(GC='TURNIKE GIRIS',ZAMAN, NULL)) AS giris, Last(IIf(GC='TURNIKE CIKIS',ZAMAN, NULL)) AS cikis, " & _
             "iif((NOT ISNULL(cikis) AND NOT ISNULL(giris)) ,cikis-giris, null) as sure " & _
             "FROM [DATA$] GROUP BY personel, cdate(Format(zaman,'Short Date')) ORDER BY PERSONEL, Cdate(Format(zaman,'Short Date'))"

    RS.Open STRSQL, strcon

    With Sheets("RAPOR")
        .Cells.ClearContents
        .Range("A1").Resize(, 5).Value = Array("PERSONEL", "TARİH", "GİRİŞ", "ÇIKIŞ", "SÜRE")
        .Range("A2").CopyFromRecordset RS
        .UsedRange.Columns("C:D").NumberFormat = "dd/mm/yyyy hh:mm:ss"
        .UsedRange.Columns("E:E").NumberFormat = "hh:mm:ss"
        .Columns.AutoFit
    End With
    RS.Close

    Set RS = Nothing
    Application.Speech.Speak "OK"
End Sub

Sub test()
    Dim ky As String
    [E:F].ClearContents
    ver = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Value
    say = -1
    ReDim lst(1 To UBound(ver) * 2, 1 To 3) As Variant
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbBinaryCompare
        For i = LBound(ver) To UBound(ver)
            ky = Trim(ver(i, 1) & "|" & Format(ver(i, 3), "dd.mm.yy"))
            If Not .Exists(ky) Then
                say = say + 2
                .Item(ky) = say
                lst(say, 1) = ver(i, 1)
                lst(say + 1, 1) = ver(i, 1)
                lst(say, 2) = "TURNIKE GIRIS"
                lst(say + 1, 2) = "TURNIKE CIKIS"
                If ver(i, 2) = "TURNIKE GIRIS" Then
                    lst(say, 3) = ver(i, 3)
                Else
                    lst(say + 1, 3) = ver(i, 3)
                End If
            Else
                If ver(i, 2) = "TURNIKE CIKIS" Then
                    sira = .Item(ky)
                    lst(sira + 1, 3) = ver(i, 3)
                End If
            End If
        Next i
        Range("D:F").Clear
        Range("D2:F2").Resize(say + 1).Value = lst
        With Range("F2:D" & say + 2)
            If WorksheetFunction.CountBlank(.Cells) > 0 Then
                .NumberFormat = "dd.mm.yyyy hh.mm.ss"
                With .SpecialCells(xlCellTypeBlanks)
                    .Interior.Color = vbRed
                    .FormulaR1C1 = "=TEXT(R[-1]C,""gg.aa.yyyy"")"
                    .Value = .Value
                End With
            End If
        End With
    End With
End Sub

Adoyla çözüm

 

[Cengiz Demir]

Bir çalışma da ben yapmıştım.
Gönder düğmesine basacakken mesaj atıldı uyarısını gördüm. . Alternatif olarak bu dosyaya da bakabilirsiniz. (Kodlama optimize değil biraz derme çatma. Ama yine de çalışıyor. )
Yalnız kodlar başka yere kopyalama yerine, olduğu yerde işlem görmeyecek satırları silerek ayıklama yapıyor.

Örnek Dosya


Ek: Sonradan farkettim. Kodlarda personel çıkışı yoksa farklı renkle işlem yapıyor ama, personel girişi yoksa onunla ilgili işlem yapmamışım. Düzenleme yapınca yeni dosyayı eklerim.

 

[bthn35]

Merhaba,
Emeğinize teşekkür ederim çok güzel olmuş, sadece bir şey daha istemem mümkün mü acaba?
Örnek excel'de sadece 1 personeli örnek alarak listelemiştim ancak 16200 satırlık bir excel'de biraz zaman alıyor bunu yapmak.
Acaba listeden bir kişiyi filtreleyerek (Örnek: ABAŞ, MURAT) sadece filtrelenen kişiye bu makroyu uygulayabilir miyiz?

http://www.dosya.tc/server17/7gn7rk/excel_sorun2.zip.html

Bir çalışma da ben yapmıştım.
Gönder düğmesine basacakken mesaj atıldı uyarısını gördüm. . Alternatif olarak bu dosyaya da bakabilirsiniz. (Kodlama optimize değil biraz derme çatma. Ama yine de çalışıyor. )
Yalnız kodlar başka yere kopyalama yerine, olduğu yerde işlem görmeyecek satırları silerek ayıklama yapıyor.

Örnek Dosya


Ek: Sonradan farkettim. Kodlarda personel çıkışı yoksa farklı renkle işlem yapıyor ama, personel girişi yoksa onunla ilgili işlem yapmamışım. Düzenleme yapınca yeni dosyayı eklerim.

 

[Cengiz Demir]

Rica ederim. Biraz çalışma yaptım. İnşallah olmuştur.

Giriş ve çıkış eksiklikleri için iki farklı renk ayarladım.
Ayrıca tarih alanına giriş ve çıkış için ilgili günün tarihini yazdırdım. Eğer rekler aynı olsun ve tarih yazmasın boş kalsın derseniz ona göre de işlem yapabilirim.

Örnek Dosya

 

[bthn35]

Merhaba,
Çok teşekkür ederim, istediğimden çok daha güzel olmuş. Şimdi de listeyi SQL'deki veriden güncellediğimde aşağıdaki hatayı veriyor.


http://www.dosya.tc/server17/ryhgzh/GECEN_AY_KGS.zip.html

 

[Cengiz Demir]

Rica ederim. Listeye filtre uygulayıp, sonra makroyu çalıştırırsanız sorun çıkmaması lazım.

 

[bthn35]

Denedim, hatta filtreyi kaldırıp tekrar uyguladım ancak hata veriyor. En son attığım linkteki dosyadan örnek görebilirsiniz.

 

[Cengiz Demir]

Az önce dosyanızı indirip denedim. Hiçbir hata vermeden işlem yapabildim.
Farklı farklı kişiler seçtim, hiçbirinde hata vermedi. Sizin bilgisayarınızda hata vermesi ilginç..

 

[bthn35]

Evet, sizin yüklediğiniz dosya çalışıyor ancak benim yüklediğim dosya çalışmıyor. Şimdi başka pcde deneyip bilgi vereceğim.

 

[bthn35]

Merhaba,
Şimdi aşağıdaki excel'i başka bilgisayarda (Office 2007)'de denedim ancak gene makroda "With ActiveSheet.AutoFilter.Range" hatası veriyor. Daha önce Office 2016'da denediğimde de aynı hatayı veriyordu. Kusura bakmayın sizi uğraştırdığım için

http://www.dosya.tc/server17/ryhgzh/GECEN_AY_KGS.zip.html

 

[Cengiz Demir]

Hatayı buldum. Liste haricinde bir hücre seçili ise, o hücrede filtre aktif olmadığı için hata veriyor.

Makronun en başına Range("A1").Select kodunu kopyalayın sorun çözülecektir.

Sub hesapla()

Range("A1").Select

 

[bthn35]

Teşekkür ederim bu sefer oldu, son bir sorunum kaldı çözemediğim, hem A1 hemde C1'de filtre varken uyguladığımda tüm listeye uyguluyor.. Range("A1:C1").Select şeklinde yaptım ama olmadı, nasıl yapmam gerekiyor?

 

[Cengiz Demir]

Makrodaki bu satırı silip. "sonhcr = Cells(Rows.Count, 1).End(xlUp).Row"

Aynı yere, aşağıdaki kodları eklerseniz sorun çözülür.

  For Each son In Range("A2:A" & Range("A1048576").End(3).Row).SpecialCells(11)

        sonhcr = son.Row

        Exit For
  Next

 

[bthn35]

Cok tesekkur ederim, emeginize saglik

 

[Cengiz Demir]

Rica ederim

 

[r2d21]

Selam;

Listedeki günün ilk saati ve son saatini alma konusunu okudum , aynı problem bende de var , dosya linklerine baktım ama çalışmıyor , rica etsem çalışan dosya örneğini burada veya mail ile paylaşabilir misiniz? Bendeki dosyaya uyarlamaya çalışayım. Teşekkürler ( serdar.ozten@gmail.com )

 

[bthn35]

Merhaba, mail attım size.

 

[ozgur26]

Maşallah maşallah inşallah