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

bthn35

Altın Üye
Katılım
12 Kasım 2009
Mesajlar
191
Excel Vers. ve Dili
365 ProPlus TR
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

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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
Kod:
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
 
Son düzenleme:

Cengiz Demir

Altın Üye
Katılım
29 Haziran 2018
Mesajlar
578
Excel Vers. ve Dili
Office 365 TR (32 Bit)
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

Altın Üye
Katılım
12 Kasım 2009
Mesajlar
191
Excel Vers. ve Dili
365 ProPlus TR
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

Altın Üye
Katılım
29 Haziran 2018
Mesajlar
578
Excel Vers. ve Dili
Office 365 TR (32 Bit)
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
 

Cengiz Demir

Altın Üye
Katılım
29 Haziran 2018
Mesajlar
578
Excel Vers. ve Dili
Office 365 TR (32 Bit)
Rica ederim. Listeye filtre uygulayıp, sonra makroyu çalıştırırsanız sorun çıkmaması lazım.
 

bthn35

Altın Üye
Katılım
12 Kasım 2009
Mesajlar
191
Excel Vers. ve Dili
365 ProPlus TR
Denedim, hatta filtreyi kaldırıp tekrar uyguladım ancak hata veriyor. En son attığım linkteki dosyadan örnek görebilirsiniz.
 

Cengiz Demir

Altın Üye
Katılım
29 Haziran 2018
Mesajlar
578
Excel Vers. ve Dili
Office 365 TR (32 Bit)
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

Altın Üye
Katılım
12 Kasım 2009
Mesajlar
191
Excel Vers. ve Dili
365 ProPlus TR
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

Altın Üye
Katılım
12 Kasım 2009
Mesajlar
191
Excel Vers. ve Dili
365 ProPlus TR
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

Altın Üye
Katılım
29 Haziran 2018
Mesajlar
578
Excel Vers. ve Dili
Office 365 TR (32 Bit)
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. ;)

Kod:
Sub hesapla()

Range("A1").Select
 
Son düzenleme:

bthn35

Altın Üye
Katılım
12 Kasım 2009
Mesajlar
191
Excel Vers. ve Dili
365 ProPlus TR
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

Altın Üye
Katılım
29 Haziran 2018
Mesajlar
578
Excel Vers. ve Dili
Office 365 TR (32 Bit)
Makrodaki bu satırı silip. "sonhcr = Cells(Rows.Count, 1).End(xlUp).Row"

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

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

        sonhcr = son.Row

        Exit For
  Next
 

r2d21

Altın Üye
Katılım
22 Kasım 2006
Mesajlar
18
Excel Vers. ve Dili
excel 2003
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 )
 
Katılım
31 Ağustos 2007
Mesajlar
30
Excel Vers. ve Dili
office 2010
Maşallah maşallah inşallah
 
Üst